From 235138882650f54410154243cc6c61122e556d6d Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Dec 2023 03:49:20 +0000 Subject: [PATCH 001/178] feat(auth): WIP support for OAuth2 --- package-lock.json | 302 +++++++++++++++++++ package.json | 1 + package.yaml | 1 + src/Application.hs | 31 +- src/Auth/OAuth2.hs | 58 ++++ src/Foundation/Instances.hs | 6 +- src/Foundation/Type.hs | 1 + src/Foundation/Yesod/Auth.hs | 80 ++++- stack.yaml | 3 + stack.yaml.lock | 551 ++++++++++++++++++----------------- 10 files changed, 757 insertions(+), 277 deletions(-) create mode 100644 src/Auth/OAuth2.hs diff --git a/package-lock.json b/package-lock.json index 8aae86886..5fedced5f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -2404,6 +2404,12 @@ "integrity": "sha512-8+9WqebbFzpX9OR+Wa6O29asIogeRMzcGtAINdpMHHyAg10f05aSFVBbcEqGf/PXw1EjAZ+q2/bEBg3DvurK3Q==", "dev": true }, + "array-flatten": { + "version": "1.1.1", + "resolved": "https://registry.npmjs.org/array-flatten/-/array-flatten-1.1.1.tgz", + "integrity": "sha512-PCVAQswWemu6UdxsDFFX/+gVeYqKAod3D3UVm91jHwynguOwAvYPhx8nNlM++NqRcK6CxxpUafjmhIdKiHibqg==", + "dev": true + }, "array-ify": { "version": "1.0.0", "resolved": "https://registry.npmjs.org/array-ify/-/array-ify-1.0.0.tgz", @@ -3519,6 +3525,23 @@ "integrity": "sha512-lGe34o6EHj9y3Kts9R4ZYs/Gr+6N7MCaMlIFA3F1R2O5/m7K06AxfSeO5530PEERE6/WyEg3lsuyw4GHlPZHog==", "dev": true }, + "basic-auth": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/basic-auth/-/basic-auth-2.0.1.tgz", + "integrity": "sha512-NF+epuEdnUYVlGuhaxbbq+dvJttwLnGY+YixlXlME5KpQ5W3CnXA5cVTneY3SPbPDRkcjMbifrwmFYcClgOZeg==", + "dev": true, + "requires": { + "safe-buffer": "5.1.2" + }, + "dependencies": { + "safe-buffer": { + "version": "5.1.2", + "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.1.2.tgz", + "integrity": "sha512-Gd2UZBJDkXlY7GbJxfsE8/nvKkUEU1G38c1siN6QP6a9PT9MmHB8GnpscSmMJSoF8LOIrt8ud/wPtojys4G6+g==", + "dev": true + } + } + }, "bcrypt-pbkdf": { "version": "1.0.2", "resolved": "https://registry.npmjs.org/bcrypt-pbkdf/-/bcrypt-pbkdf-1.0.2.tgz", @@ -4142,6 +4165,15 @@ } } }, + "content-disposition": { + "version": "0.5.4", + "resolved": "https://registry.npmjs.org/content-disposition/-/content-disposition-0.5.4.tgz", + "integrity": "sha512-FveZTNuGw04cxlAiWbzi6zTAL/lhehaWbTtgluJh4/E95DqMwTmha3KZN1aAWA8cFIhHzMZUvLevkw5Rqk+tSQ==", + "dev": true, + "requires": { + "safe-buffer": "5.2.1" + } + }, "content-type": { "version": "1.0.4", "resolved": "https://registry.npmjs.org/content-type/-/content-type-1.0.4.tgz", @@ -4517,6 +4549,12 @@ "integrity": "sha512-aSWTXFzaKWkvHO1Ny/s+ePFpvKsPnjc551iI41v3ny/ow6tBG5Vd+FuqGNhh1LxOmVzOlGUriIlOaokOvhaStA==", "dev": true }, + "cookie-signature": { + "version": "1.0.6", + "resolved": "https://registry.npmjs.org/cookie-signature/-/cookie-signature-1.0.6.tgz", + "integrity": "sha512-QADzlaHc8icV8I7vbaJXJwod9HWYp8uCqf1xa4OfNu1T7JVxQIrUgOWtHdNDtPiywmFbiS12VjotIXLrKM3orQ==", + "dev": true + }, "copy-webpack-plugin": { "version": "11.0.0", "resolved": "https://registry.npmjs.org/copy-webpack-plugin/-/copy-webpack-plugin-11.0.0.tgz", @@ -5036,6 +5074,12 @@ "integrity": "sha1-3zrhmayt+31ECqrgsp4icrJOxhk=", "dev": true }, + "depd": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/depd/-/depd-2.0.0.tgz", + "integrity": "sha512-g7nH6P6dyDioJogAAGprGpCtVImJhpPk/roCzdb3fIh61/s/nPsfR6onyMwkCAR/OlC3yBC0lESvUoQEAssIrw==", + "dev": true + }, "destroy": { "version": "1.2.0", "resolved": "https://registry.npmjs.org/destroy/-/destroy-1.2.0.tgz", @@ -5629,6 +5673,12 @@ "integrity": "sha512-kVscqXk4OCp68SZ0dkgEKVi6/8ij300KBWTJq32P/dYeWTSwK41WyTxalN1eRmA5Z9UU/LX9D7FWSmV9SAYx6g==", "dev": true }, + "etag": { + "version": "1.8.1", + "resolved": "https://registry.npmjs.org/etag/-/etag-1.8.1.tgz", + "integrity": "sha512-aIL5Fx7mawVa300al2BnEE4iNvo1qETxLrPI/o05L7z6go7fCw1J6EQmbK4FmJ2AS7kgVF/KEZWufBfdClMcPg==", + "dev": true + }, "eventemitter3": { "version": "4.0.7", "resolved": "https://registry.npmjs.org/eventemitter3/-/eventemitter3-4.0.7.tgz", @@ -5666,6 +5716,112 @@ } } }, + "express": { + "version": "4.18.2", + "resolved": "https://registry.npmjs.org/express/-/express-4.18.2.tgz", + "integrity": "sha512-5/PsL6iGPdfQ/lKM1UuielYgv3BUoJfz1aUwU9vHZ+J7gyvwdQXFEBIEIaxeGf0GIcreATNyBExtalisDbuMqQ==", + "dev": true, + "requires": { + "accepts": "~1.3.8", + "array-flatten": "1.1.1", + "body-parser": "1.20.1", + "content-disposition": "0.5.4", + "content-type": "~1.0.4", + "cookie": "0.5.0", + "cookie-signature": "1.0.6", + "debug": "2.6.9", + "depd": "2.0.0", + "encodeurl": "~1.0.2", + "escape-html": "~1.0.3", + "etag": "~1.8.1", + "finalhandler": "1.2.0", + "fresh": "0.5.2", + "http-errors": "2.0.0", + "merge-descriptors": "1.0.1", + "methods": "~1.1.2", + "on-finished": "2.4.1", + "parseurl": "~1.3.3", + "path-to-regexp": "0.1.7", + "proxy-addr": "~2.0.7", + "qs": "6.11.0", + "range-parser": "~1.2.1", + "safe-buffer": "5.2.1", + "send": "0.18.0", + "serve-static": "1.15.0", + "setprototypeof": "1.2.0", + "statuses": "2.0.1", + "type-is": "~1.6.18", + "utils-merge": "1.0.1", + "vary": "~1.1.2" + }, + "dependencies": { + "body-parser": { + "version": "1.20.1", + "resolved": "https://registry.npmjs.org/body-parser/-/body-parser-1.20.1.tgz", + "integrity": "sha512-jWi7abTbYwajOytWCQc37VulmWiRae5RyTpaCyDcS5/lMdtwSz5lOpDE67srw/HYe35f1z3fDQw+3txg7gNtWw==", + "dev": true, + "requires": { + "bytes": "3.1.2", + "content-type": "~1.0.4", + "debug": "2.6.9", + "depd": "2.0.0", + "destroy": "1.2.0", + "http-errors": "2.0.0", + "iconv-lite": "0.4.24", + "on-finished": "2.4.1", + "qs": "6.11.0", + "raw-body": "2.5.1", + "type-is": "~1.6.18", + "unpipe": "1.0.0" + } + }, + "cookie": { + "version": "0.5.0", + "resolved": "https://registry.npmjs.org/cookie/-/cookie-0.5.0.tgz", + "integrity": "sha512-YZ3GUyn/o8gfKJlnlX7g7xq4gyO6OSuhGPKaaGssGB2qgDUS0gPgtTvoyZLTt9Ab6dC4hfc9dV5arkvc/OCmrw==", + "dev": true + }, + "debug": { + "version": "2.6.9", + "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz", + "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==", + "dev": true, + "requires": { + "ms": "2.0.0" + } + }, + "finalhandler": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/finalhandler/-/finalhandler-1.2.0.tgz", + "integrity": "sha512-5uXcUVftlQMFnWC9qu/svkWv3GTd2PfUhK/3PLkYNAe7FbqJMt3515HaxE6eRL74GdsriiwujiawdaB1BpEISg==", + "dev": true, + "requires": { + "debug": "2.6.9", + "encodeurl": "~1.0.2", + "escape-html": "~1.0.3", + "on-finished": "2.4.1", + "parseurl": "~1.3.3", + "statuses": "2.0.1", + "unpipe": "~1.0.0" + } + }, + "ms": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz", + "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==", + "dev": true + }, + "qs": { + "version": "6.11.0", + "resolved": "https://registry.npmjs.org/qs/-/qs-6.11.0.tgz", + "integrity": "sha512-MvjoMCJwEarSbUYk5O+nmoSzSutSsTwF85zcHPQ9OrlFoZOYIjaqBAJIqIXjptyD5vThxGq52Xu/MaJzRkIk4Q==", + "dev": true, + "requires": { + "side-channel": "^1.0.4" + } + } + } + }, "extend": { "version": "3.0.2", "resolved": "https://registry.npmjs.org/extend/-/extend-3.0.2.tgz", @@ -5881,12 +6037,24 @@ "mime-types": "^2.1.12" } }, + "forwarded": { + "version": "0.2.0", + "resolved": "https://registry.npmjs.org/forwarded/-/forwarded-0.2.0.tgz", + "integrity": "sha512-buRG0fpBtRHSTCOASe6hD258tEubFoRLb4ZNA6NxMVHNw2gOcwHo9wyablzMzOA5z9xA9L1KNjk/Nt6MT9aYow==", + "dev": true + }, "fraction.js": { "version": "4.2.0", "resolved": "https://registry.npmjs.org/fraction.js/-/fraction.js-4.2.0.tgz", "integrity": "sha512-MhLuK+2gUcnZe8ZHlaaINnQLl0xRIGRfcGk2yl8xoQAfHrSsL3rYu6FCmBdkdbhc9EPlwyGHewaRsvwRMJtAlA==", "dev": true }, + "fresh": { + "version": "0.5.2", + "resolved": "https://registry.npmjs.org/fresh/-/fresh-0.5.2.tgz", + "integrity": "sha512-zJ2mQYM18rEFOudeV4GShTGIQ7RbzA7ozbU9I/XBpm7kqgMywgmylMwXHxZJmkVoYkna9d2pVXVXPdYTP9ej8Q==", + "dev": true + }, "fs-extra": { "version": "10.1.0", "resolved": "https://registry.npmjs.org/fs-extra/-/fs-extra-10.1.0.tgz", @@ -6441,6 +6609,15 @@ "integrity": "sha512-xs7/chUH/CKdOCs7Zy0Aev9e/dKOMZf3K1Az1nar3tzlv0jfqnYtu235bstsWTmXOR0EfINrPa97yy4Lz6RiKw==", "dev": true }, + "iconv-lite": { + "version": "0.4.24", + "resolved": "https://registry.npmjs.org/iconv-lite/-/iconv-lite-0.4.24.tgz", + "integrity": "sha512-v3MXnZAcvnywkTUEZomIActle7RXXeedOR31wwl7VlyoXO4Qi9arvSenNQWne1TcRwhCL1HwLI21bEqdpj8/rA==", + "dev": true, + "requires": { + "safer-buffer": ">= 2.1.2 < 3" + } + }, "icss-utils": { "version": "5.1.0", "resolved": "https://registry.npmjs.org/icss-utils/-/icss-utils-5.1.0.tgz", @@ -6541,6 +6718,12 @@ "loose-envify": "^1.0.0" } }, + "ipaddr.js": { + "version": "1.9.1", + "resolved": "https://registry.npmjs.org/ipaddr.js/-/ipaddr.js-1.9.1.tgz", + "integrity": "sha512-0KI/607xoxSToH7GjN1FfSbLoU0+btTicjsQSWQlh/hZykN8KpmMf7uYwPW3R+akZ6R/w18ZlXSHBYXiYUPO3g==", + "dev": true + }, "is-arrayish": { "version": "0.2.1", "resolved": "https://registry.npmjs.org/is-arrayish/-/is-arrayish-0.2.1.tgz", @@ -6825,6 +7008,12 @@ } } }, + "jose": { + "version": "4.15.4", + "resolved": "https://registry.npmjs.org/jose/-/jose-4.15.4.tgz", + "integrity": "sha512-W+oqK4H+r5sITxfxpSU+MMdr/YSWGvgZMQDIsNoBDGGy4i7GBPTtvFKibQzW06n3U3TqHjhvBJsirShsEJ6eeQ==", + "dev": true + }, "js-cookie": { "version": "3.0.1", "resolved": "https://registry.npmjs.org/js-cookie/-/js-cookie-3.0.1.tgz", @@ -7822,6 +8011,12 @@ } } }, + "merge-descriptors": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/merge-descriptors/-/merge-descriptors-1.0.1.tgz", + "integrity": "sha512-cCi6g3/Zr1iqQi6ySbseM1Xvooa98N0w31jzUYrXPX2xqObmFGHJ0tQ5u74H3mVh7wLouTseZyYIq39g8cNp1w==", + "dev": true + }, "merge-stream": { "version": "2.0.0", "resolved": "https://registry.npmjs.org/merge-stream/-/merge-stream-2.0.0.tgz", @@ -7846,6 +8041,12 @@ "underscore": "*" } }, + "methods": { + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/methods/-/methods-1.1.2.tgz", + "integrity": "sha512-iclAHeNqNm68zFtnZ0e+1L2yUIdvzNoauKU4WBA3VvH/vPFieF7qfRlwUZU+DA9P9bPXIS90ulxoUoCH23sV2w==", + "dev": true + }, "micromatch": { "version": "4.0.5", "resolved": "https://registry.npmjs.org/micromatch/-/micromatch-4.0.5.tgz", @@ -9854,6 +10055,27 @@ } } }, + "oauth2-mock-server": { + "version": "7.1.1", + "resolved": "https://registry.npmjs.org/oauth2-mock-server/-/oauth2-mock-server-7.1.1.tgz", + "integrity": "sha512-4/PdPZLySsC68IoiO79BKpr5Rv2j2+WgFZskox7bzSlsXqoX8Nm9OWm3IXB0HQ7xJCbzcR4vvvcDe6UnA/UIiw==", + "dev": true, + "requires": { + "basic-auth": "^2.0.1", + "cors": "^2.8.5", + "express": "^4.18.2", + "is-plain-object": "^5.0.0", + "jose": "^4.15.4" + }, + "dependencies": { + "is-plain-object": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/is-plain-object/-/is-plain-object-5.0.0.tgz", + "integrity": "sha512-VRSzKkbMm5jMDoKLbltAkFQ5Qr7VDiTFGXxYFXXowVj387GeGNOCsOH6Msy00SGZ3Fp84b1Naa1psqgcCIEP5Q==", + "dev": true + } + } + }, "object-assign": { "version": "4.1.1", "resolved": "https://registry.npmjs.org/object-assign/-/object-assign-4.1.1.tgz", @@ -10064,6 +10286,12 @@ "integrity": "sha512-LDJzPVEEEPR+y48z93A0Ed0yXb8pAByGWo/k5YYdYgpY2/2EsOsksJrq7lOHxryrVOn1ejG6oAp8ahvOIQD8sw==", "dev": true }, + "path-to-regexp": { + "version": "0.1.7", + "resolved": "https://registry.npmjs.org/path-to-regexp/-/path-to-regexp-0.1.7.tgz", + "integrity": "sha512-5DFkuoqlv1uYQKxy8omFBeJPQcdoE07Kv2sferDCrAq1ohOU+MSDswDIbnx3YAM60qIOnYa53wBhXW0EbMonrQ==", + "dev": true + }, "path-type": { "version": "4.0.0", "resolved": "https://registry.npmjs.org/path-type/-/path-type-4.0.0.tgz", @@ -10818,6 +11046,16 @@ "integrity": "sha512-3ouUOpQhtgrbOa17J7+uxOTpITYWaGP7/AhoR3+A+/1e9skrzelGi/dXzEYyvbxubEF6Wn2ypscTKiKJFFn1ag==", "dev": true }, + "proxy-addr": { + "version": "2.0.7", + "resolved": "https://registry.npmjs.org/proxy-addr/-/proxy-addr-2.0.7.tgz", + "integrity": "sha512-llQsMLSUDUPT44jdrU/O37qlnifitDP+ZwrmmZcoSKyLKvtZxpyV0n2/bD/N4tBAAZ/gJEdZU7KMraoK1+XYAg==", + "dev": true, + "requires": { + "forwarded": "0.2.0", + "ipaddr.js": "1.9.1" + } + }, "psl": { "version": "1.8.0", "resolved": "https://registry.npmjs.org/psl/-/psl-1.8.0.tgz", @@ -11557,6 +11795,58 @@ } } }, + "send": { + "version": "0.18.0", + "resolved": "https://registry.npmjs.org/send/-/send-0.18.0.tgz", + "integrity": "sha512-qqWzuOjSFOuqPjFe4NOsMLafToQQwBSOEpS+FwEt3A2V3vKubTquT3vmLTQpFgMXp8AlFWFuP1qKaJZOtPpVXg==", + "dev": true, + "requires": { + "debug": "2.6.9", + "depd": "2.0.0", + "destroy": "1.2.0", + "encodeurl": "~1.0.2", + "escape-html": "~1.0.3", + "etag": "~1.8.1", + "fresh": "0.5.2", + "http-errors": "2.0.0", + "mime": "1.6.0", + "ms": "2.1.3", + "on-finished": "2.4.1", + "range-parser": "~1.2.1", + "statuses": "2.0.1" + }, + "dependencies": { + "debug": { + "version": "2.6.9", + "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz", + "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==", + "dev": true, + "requires": { + "ms": "2.0.0" + }, + "dependencies": { + "ms": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz", + "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==", + "dev": true + } + } + }, + "mime": { + "version": "1.6.0", + "resolved": "https://registry.npmjs.org/mime/-/mime-1.6.0.tgz", + "integrity": "sha512-x0Vn8spI+wuJ1O6S7gnbaQg8Pxh4NNHb7KSINmEWKiPE4RKOplvijn+NkmYmmRgP68mc70j2EbeTFRsrswaQeg==", + "dev": true + }, + "ms": { + "version": "2.1.3", + "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.3.tgz", + "integrity": "sha512-6FlzubTLZG3J2a/NVCAleEhjzq5oxgHyaCU9yYXvcLsvoVaHJq/s5xXI6/XXP6tz7R9xAOtHnSO/tXtF3WRTlA==", + "dev": true + } + } + }, "serialize-javascript": { "version": "6.0.0", "resolved": "https://registry.npmjs.org/serialize-javascript/-/serialize-javascript-6.0.0.tgz", @@ -11566,6 +11856,18 @@ "randombytes": "^2.1.0" } }, + "serve-static": { + "version": "1.15.0", + "resolved": "https://registry.npmjs.org/serve-static/-/serve-static-1.15.0.tgz", + "integrity": "sha512-XGuRDNjXUijsUL0vl6nSD7cwURuzEgglbOaFuZM9g3kwDXOWVTck0jLzjPzGD+TazWbboZYu52/9/XPdUgne9g==", + "dev": true, + "requires": { + "encodeurl": "~1.0.2", + "escape-html": "~1.0.3", + "parseurl": "~1.3.3", + "send": "0.18.0" + } + }, "setimmediate": { "version": "1.0.5", "resolved": "https://registry.npmjs.org/setimmediate/-/setimmediate-1.0.5.tgz", diff --git a/package.json b/package.json index e7e8a6e47..f31e8c86b 100644 --- a/package.json +++ b/package.json @@ -86,6 +86,7 @@ "mini-css-extract-plugin": "^2.6.0", "npm-run-all": "^4.1.5", "null-loader": "^4.0.1", + "oauth2-mock-server": "^7.1.1", "optimize-css-assets-webpack-plugin": "^6.0.1", "postcss-loader": "^7.0.0", "postcss-preset-env": "^7.7.1", diff --git a/package.yaml b/package.yaml index c6e1a8bcb..c976fcbcb 100644 --- a/package.yaml +++ b/package.yaml @@ -6,6 +6,7 @@ dependencies: - yesod-core - yesod-persistent - yesod-auth + - yesod-auth-oauth2 - yesod-static - yesod-form - yesod-persistent diff --git a/src/Application.hs b/src/Application.hs index 45f24768e..c6f2cb68c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -60,7 +60,9 @@ import System.Directory import Jobs import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2) import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS @@ -124,6 +126,8 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations) import qualified System.Clock as Clock +import Data.Maybe (fromJust) + import Utils.Avs -- Import all relevant handler modules here. @@ -166,6 +170,8 @@ import Servant.API import Servant.Client import Network.HTTP.Client.TLS (mkManagerSettings) +import Auth.OAuth2 + -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -235,7 +241,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") @@ -252,10 +258,12 @@ makeFoundation appSettings''@AppSettings{..} = do (error "MinioConn forced in tempFoundation") (error "VerpSecret forced in tempFoundation") (error "AuthKey forced in tempFoundation") + (error "AuthPlugins forced in tempFoundation") (error "PersonalisedSheetFilesSeedKey forced in tempFoundation") (error "VolatileClusterSettingsCache forced in tempFoundation") (error "AvsQuery forced in tempFoundation") + runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID $logInfoS "Configuration" $ tshowCrop appSettings'' @@ -317,6 +325,23 @@ makeFoundation appSettings''@AppSettings{..} = do appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool + + mAzureTenantID <- liftIO $ (fmap Text.pack) <$> lookupEnv "AZURE_ADV2_TENANT_ID" + let -- Auth Plugins + tenantID = fromMaybe (error "Tenant ID mising") mAzureTenantID + loadPlugin p prefix = do -- Loads given YesodAuthPlugin + mID <- (fmap Text.pack) <$> (lookupEnv $ prefix ++ "_CLIENT_ID") + mSecret <- (fmap Text.pack) <$> (lookupEnv $ prefix ++ "_CLIENT_SECRET") + let mArgs = (,) <$> mID <*> mSecret + guard $ isJust mArgs + return . uncurry p $ fromJust mArgs + + appAuthPlugins <- liftIO $ sequence [ + return oauth2MockServer + , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2" + ] + + let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns where (MkFixed ns :: Nano) = realToFrac appVolatileClusterSettingsCacheTime appVolatileClusterSettingsCache <- newTVarIO $ mkVolatileClusterSettingsCache appVolatileClusterSettingsCacheTime' @@ -376,7 +401,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logInfoS "setup" "*** DONE ***" diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs new file mode 100644 index 000000000..30a75a206 --- /dev/null +++ b/src/Auth/OAuth2.hs @@ -0,0 +1,58 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Auth.OAuth2 +( OAuthUserException(..) +, oauth2MockServer +, mockPluginName +) where + +import Data.Text + +import Import.NoFoundation + +import Yesod.Auth.OAuth2 +import Yesod.Auth.OAuth2.Prelude + + +data OAuthUserException = OAuthUserError + | OAuthUserAmbiguous -- TODO + deriving (Show, Eq, Generic) + +instance Exception OAuthUserException + +---------------------------------------- +---- OAuth2 development auth plugin ---- +---------------------------------------- + +mockPluginName :: Text +mockPluginName = "uniworx_dev" + +newtype UserID = UserID Text +instance FromJSON UserID where + parseJSON = withObject "UserID" $ \o -> + UserID <$> o .: "id" + +oauth2MockServer :: YesodAuth m => AuthPlugin m +oauth2MockServer = + let oa = OAuth2 + { oauth2ClientId = "uniworx" + , oauth2ClientSecret = Just "shh" + , oauth2AuthorizeEndpoint = fromString $ mockServerURL <> "/authorize" + , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token" + , oauth2RedirectUri = Nothing + } + mockServerURL = "0.0.0.0/" + profileSrc = fromString $ mockServerURL <> "/foo" + in authOAuth2 mockPluginName oa $ \manager token -> do + (UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc + return Creds + { credsPlugin = mockPluginName + , credsIdent = userID + , credsExtra = setExtra token userResponse + } + + diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index b7d6a555b..0b3e23892 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -139,9 +139,9 @@ instance YesodAuth UniWorX where setTitleI MsgLoginTitle $(widgetFile "login") - authenticate = UniWorX.authenticate + authenticate = UniWorX.oAuthenticate -- UniWorX.authenticate - authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes + authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes [ flip campusLogin campusUserFailoverMode <$> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 5c77e9863..7fe72bac3 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -97,6 +97,7 @@ data UniWorX = UniWorX , appUploadCache :: Maybe MinioConn , appVerpSecret :: VerpSecret , appAuthKey :: Auth.Key + , appAuthPlugins :: [AuthPlugin UniWorX] , appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString) , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString) , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference)) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index efabadc80..f394ee1f3 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,9 +1,10 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Foundation.Yesod.Auth ( authenticate + , oAuthenticate , ldapLookupAndUpsert , upsertCampusUser , decodeUserTest @@ -56,6 +57,7 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX ) => Creds UniWorX -> m (AuthenticationResult UniWorX) authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do + $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" now <- liftIO getCurrentTime let @@ -120,6 +122,82 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend -> acceptExisting +-- | Authentication via OAuth 2 +oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX + , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) + , YesodAuth UniWorX, UserId ~ AuthId UniWorX + ) + => Creds UniWorX -> m (AuthenticationResult UniWorX) +oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do + $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + now <- liftIO getCurrentTime + + let + uAuth = UniqueAuthentication $ CI.mk credsIdent + upsertMode = creds ^? _upsertCampusUserMode -- TODO adjust do OAuth + + isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode + isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode + + excRecovery res + | isDummy || isOther + = do + case res of + UserError err -> addMessageI Error err + ServerError err -> addMessage Error $ toHtml err + _other -> return () + acceptExisting + | otherwise + = return res + + excHandlers = + [ C.Handler $ \case + CampusUserNoResult -> do + $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + CampusUserAmbiguous -> do + $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + err -> do + $logErrorS "LDAP" $ tshow err + mr <- getMessageRender + excRecovery . ServerError $ mr MsgInternalLdapError + , C.Handler $ \(cExc :: CampusUserConversionException) -> do + $logErrorS "LDAP" $ tshow cExc + mr <- getMessageRender + excRecovery . ServerError $ mr cExc + ] + + acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) + acceptExisting = do + res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + case res of + Authenticated uid + -> associateUserSchoolsByTerms uid + _other + -> return () + case res of + Authenticated uid + | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] + _other -> return res + + $logDebugS "auth" $ tshow Creds{..} + pool <- getsYesod $ view _appLdapPool {-(case credsPlugin of + "azureadv2" -> getsYesod $ view _appLdapPool -- TODO + mockPluginName -> getsYesod $ view _appLdapPool -- TODO + _ -> error "undefined" -- TODO + )-} + flip catches excHandlers $ case pool of + Just ldapPool + | Just upsertMode' <- upsertMode -> do + ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} + $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData + Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData + _other + -> acceptExisting + + + data CampusUserConversionException = CampusUserInvalidIdent | CampusUserInvalidEmail diff --git a/stack.yaml b/stack.yaml index 2c7b72c31..e5b66c6db 100644 --- a/stack.yaml +++ b/stack.yaml @@ -88,6 +88,9 @@ extra-deps: - yesod-eventsource - yesod-websockets + - git: https://github.com/freckle/yesod-auth-oauth2 + commit: 11948a65c405f1a99ccb327d328d416e492542a1 + - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f diff --git a/stack.yaml.lock b/stack.yaml.lock index cb7c7063a..d6c9f21c4 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,539 +5,550 @@ packages: - completed: + commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git name: encoding - version: 0.8.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git pantry-tree: - size: 5723 sha256: fec12328951021bb4d9326ae0b35f0c459e65f28442366efd4366cd1e18abe19 - commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 + size: 5723 + version: 0.8.2 original: + commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git - commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 - completed: + commit: b7071df50bad3a251a544b984e4bf98fa09b8fae + git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git name: memcached-binary - version: 0.2.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git pantry-tree: - size: 1277 sha256: 0da0539b7b9a56d03a116dcd666bc1bbbef085659910420849484d1418aa0857 - commit: b7071df50bad3a251a544b984e4bf98fa09b8fae + size: 1277 + version: 0.2.0 original: + commit: b7071df50bad3a251a544b984e4bf98fa09b8fae git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git - commit: b7071df50bad3a251a544b984e4bf98fa09b8fae - completed: + commit: cbea6159c2975d42f948525e03e12fc390da53c5 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git name: conduit-resumablesink - version: '0.3' - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git pantry-tree: - size: 394 sha256: 0cccf4684bbd84f81d2d3d53dd81c46cb103b5322f1d8e89e9b222211281e1b7 - commit: cbea6159c2975d42f948525e03e12fc390da53c5 + size: 394 + version: '0.3' original: + commit: cbea6159c2975d42f948525e03e12fc390da53c5 git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git - commit: cbea6159c2975d42f948525e03e12fc390da53c5 - completed: + commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 + git: https://github.com/jtdaugherty/HaskellNet.git name: HaskellNet - version: 0.5.1 - git: https://github.com/jtdaugherty/HaskellNet.git pantry-tree: - size: 4011 sha256: 921b437ef18ccb04f889301c407263d6b5b72c5864803a000b1e61328988ce70 - commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 + size: 4011 + version: 0.5.1 original: + commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 git: https://github.com/jtdaugherty/HaskellNet.git - commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 - completed: + commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git name: HaskellNet-SSL - version: 0.3.4.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git pantry-tree: - size: 841 sha256: 95dcec22fdb8af986e59f0f60aa76d4a48f34a546dca799bd571e1d183f773e0 - commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 + size: 841 + version: 0.3.4.1 original: + commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git - commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 - completed: + commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git name: ldap-client - version: 0.4.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git pantry-tree: - size: 6176 sha256: 3fa8f102427b437b2baaec15cf884e88b47a1621b1c3fd4d8919f0263fde8656 - commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 + size: 6176 + version: 0.4.0 original: + commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git - commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 - completed: - subdir: serversession + commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git name: serversession - version: 1.0.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git pantry-tree: - size: 545 sha256: 83ac78a987399db3da62f84bbd335fead11aadebd57251d0688127fca984db23 - commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 - original: + size: 545 subdir: serversession - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + version: 1.0.2 + original: commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + subdir: serversession - completed: - subdir: serversession-backend-acid-state + commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git name: serversession-backend-acid-state - version: 1.0.4 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git pantry-tree: - size: 544 sha256: 4804260c6245c12e1728c78dd33bf16e95b7f2b69b38b6900a4e65b1ef3e04b7 - commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 - original: + size: 544 subdir: serversession-backend-acid-state - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + version: 1.0.4 + original: commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + subdir: serversession-backend-acid-state - completed: + commit: dc928c3a456074b8777603bea20e81937321777f + git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git name: xss-sanitize - version: 0.3.6 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git pantry-tree: - size: 750 sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975 - commit: dc928c3a456074b8777603bea20e81937321777f + size: 750 + version: 0.3.6 original: + commit: dc928c3a456074b8777603bea20e81937321777f git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git - commit: dc928c3a456074b8777603bea20e81937321777f - completed: - subdir: colonnade + commit: f8170266ab25b533576e96715bedffc5aa4f19fa + git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git name: colonnade - version: 1.2.0.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git pantry-tree: - size: 481 sha256: 392393652cc0f354d351482557b9385c8e6122e706359b030373656565f2e045 - commit: f8170266ab25b533576e96715bedffc5aa4f19fa - original: + size: 481 subdir: colonnade - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git + version: 1.2.0.2 + original: commit: f8170266ab25b533576e96715bedffc5aa4f19fa + git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git + subdir: colonnade - completed: + commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git name: minio-hs - version: 1.5.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git pantry-tree: - size: 4560 sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc - commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 + size: 4560 + version: 1.5.2 original: + commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git - commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 - completed: - subdir: cryptoids-class + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git name: cryptoids-class - version: 0.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git pantry-tree: - size: 412 sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203 - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: + size: 412 subdir: cryptoids-class - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: cryptoids-types - name: cryptoids-types - version: 1.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 320 - sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: cryptoids-types - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: cryptoids - name: cryptoids - version: 0.5.1.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 566 - sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: cryptoids - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: filepath-crypto - name: filepath-crypto - version: 0.1.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 676 - sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9 - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: filepath-crypto - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: uuid-crypto - name: uuid-crypto - version: 1.4.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 417 - sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4 - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: uuid-crypto - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: gearhash - name: gearhash - version: 1.0.0 - git: https://github.com/gkleen/FastCDC.git - pantry-tree: - size: 551 - sha256: 89c58554f6780bff2a2cab86e94d2f562eea34e8025a9925bfdc25b56c925d3e - commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d - original: - subdir: gearhash - git: https://github.com/gkleen/FastCDC.git - commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d -- completed: - subdir: fastcdc - name: fastcdc version: 0.0.0 - git: https://github.com/gkleen/FastCDC.git + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + subdir: cryptoids-class +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + name: cryptoids-types + pantry-tree: + sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e + size: 320 + subdir: cryptoids-types + version: 1.0.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + subdir: cryptoids-types +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + name: cryptoids + pantry-tree: + sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb + size: 566 + subdir: cryptoids + version: 0.5.1.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + subdir: cryptoids +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + name: filepath-crypto + pantry-tree: + sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9 + size: 676 + subdir: filepath-crypto + version: 0.1.0.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + subdir: filepath-crypto +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + name: uuid-crypto + pantry-tree: + sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4 + size: 417 + subdir: uuid-crypto + version: 1.4.0.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + subdir: uuid-crypto +- completed: + commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + name: gearhash + pantry-tree: + sha256: 89c58554f6780bff2a2cab86e94d2f562eea34e8025a9925bfdc25b56c925d3e + size: 551 + subdir: gearhash + version: 1.0.0 + original: + commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + subdir: gearhash +- completed: + commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + name: fastcdc pantry-tree: - size: 292 sha256: aa588b55c7c9c079e39569489a8089ec312f0538d02cf0e1fffe2f0e058566b8 - commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d - original: + size: 292 subdir: fastcdc - git: https://github.com/gkleen/FastCDC.git + version: 0.0.0 + original: commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + subdir: fastcdc - completed: + commit: 843683d024f767de236f74d24a3348f69181a720 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git name: zip-stream - version: 0.2.0.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git pantry-tree: - size: 812 sha256: 0da8bc38d73034962d2e2d1a7586b6dee848a629319fce9cbbf578348c61118c - commit: 843683d024f767de236f74d24a3348f69181a720 + size: 812 + version: 0.2.0.1 original: + commit: 843683d024f767de236f74d24a3348f69181a720 git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git - commit: 843683d024f767de236f74d24a3348f69181a720 - completed: - subdir: yesod-core + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-core - version: 1.6.20.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 5954 sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 5954 subdir: yesod-core - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.20.2 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-core - completed: - subdir: yesod-static + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-static - version: 1.6.1.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 2949 sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 2949 subdir: yesod-static - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.1.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-static - completed: - subdir: yesod-persistent + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-persistent - version: 1.6.0.7 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 497 sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 497 subdir: yesod-persistent - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0.7 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-persistent - completed: - subdir: yesod-newsfeed + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-newsfeed - version: 1.7.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 488 sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 488 subdir: yesod-newsfeed - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.7.0.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-newsfeed - completed: - subdir: yesod-form + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-form - version: 1.7.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 1914 sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 1914 subdir: yesod-form - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.7.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-form - completed: - subdir: yesod-form-multi + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-form-multi - version: 1.7.0.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 328 sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 328 subdir: yesod-form-multi - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.7.0.2 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-form-multi - completed: - subdir: yesod-auth + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-auth - version: 1.6.10.3 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 1212 sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 1212 subdir: yesod-auth - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.10.3 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-auth - completed: - subdir: yesod-auth-oauth + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-auth-oauth - version: 1.6.0.3 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 321 sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 321 subdir: yesod-auth-oauth - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0.3 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-auth-oauth - completed: - subdir: yesod-sitemap + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-sitemap - version: 1.6.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 314 sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 314 subdir: yesod-sitemap - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-sitemap - completed: - subdir: yesod-test + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-test - version: 1.6.12 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 563 sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 563 subdir: yesod-test - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.12 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-test - completed: - subdir: yesod-bin + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-bin - version: 1.6.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 1295 sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 1295 subdir: yesod-bin - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.1 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-bin - completed: - subdir: yesod + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod - version: 1.6.1.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 666 sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 666 subdir: yesod - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.1.1 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod - completed: - subdir: yesod-eventsource + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-eventsource - version: 1.6.0.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 324 sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 324 subdir: yesod-eventsource - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0.1 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-eventsource - completed: - subdir: yesod-websockets + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git name: yesod-websockets - version: 0.3.0.3 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 485 sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 485 subdir: yesod-websockets - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 0.3.0.3 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + subdir: yesod-websockets - completed: + commit: 11948a65c405f1a99ccb327d328d416e492542a1 + git: https://github.com/freckle/yesod-auth-oauth2 + name: yesod-auth-oauth2 + pantry-tree: + sha256: a68ec51e1008c315dd15e81cc3ac1f4e2adfd3db623259395757ecae2787cef2 + size: 4277 + version: 0.7.1.3 + original: + commit: 11948a65c405f1a99ccb327d328d416e492542a1 + git: https://github.com/freckle/yesod-auth-oauth2 +- completed: + commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f + git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git name: cryptonite - version: '0.29' - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git pantry-tree: - size: 25056 sha256: 19e49259fa5e3c257495d72b3c7c3c49537aeafd508c780c2430ddca2ef71a91 - commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f + size: 25056 + version: '0.29' original: + commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git - commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f - completed: + commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git name: esqueleto - version: 3.5.4.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git pantry-tree: - size: 5633 sha256: 8a93dc98eb4529ff64aa5bcdaa3c00dcdf0378033ad675864e2b0fc3d869d947 - commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 + size: 5633 + version: 3.5.4.0 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 + git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git - completed: hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 pantry-tree: - size: 330 sha256: ae84d4cc0e1daf985db6cdcf2ac92319531b8e60f547183cc46480d00aafbe20 + size: 330 original: hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 - completed: hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 pantry-tree: - size: 13678 sha256: d57bcb2ad5e01fe7424abbcf9e58cf943027b5c4a8496d93625c57b6e1272274 + size: 13678 original: hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 - completed: hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 pantry-tree: - size: 269 sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c + size: 269 original: hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 - completed: hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 pantry-tree: - size: 316 sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c + size: 316 original: hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 - completed: hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 pantry-tree: - size: 446 sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373 + size: 446 original: hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 - completed: hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 pantry-tree: - size: 399 sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa + size: 399 original: hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 - completed: hackage: tz-0.1.3.5@sha256:fb17ca50a7d943e511c0ca70342dc83f66aa2532de2745632f1f5f9b1ad783c4,5086 pantry-tree: - size: 1179 sha256: 6482698ea1b1a93bd684fca35836b35e8cdf53fe51b0fa6b215afa7da1f983a6 + size: 1179 original: hackage: tz-0.1.3.5@sha256:fb17ca50a7d943e511c0ca70342dc83f66aa2532de2745632f1f5f9b1ad783c4,5086 - completed: hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 pantry-tree: - size: 492 sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283 + size: 492 original: hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - completed: hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 pantry-tree: - size: 442 sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea + size: 442 original: hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 - completed: hackage: servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755 pantry-tree: - size: 976 sha256: 37dab60111c71d011fc4964e9a8b4b05ac544bc0ba8155e895518680066c2adb + size: 976 original: hackage: servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755 - completed: hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 pantry-tree: - size: 325 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 + size: 325 original: hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 - completed: hackage: network-arbitrary-0.7.0.0@sha256:0cd381c80ae20c16048936edcdb018b1d9fbe2b6ac8c44e908df403a5c6d7cd5,2520 pantry-tree: - size: 912 sha256: a40b62eddfb12cfec753a10836a4ef5fe8ec94d7478e6957e1fe5729017928fb + size: 912 original: hackage: network-arbitrary-0.7.0.0@sha256:0cd381c80ae20c16048936edcdb018b1d9fbe2b6ac8c44e908df403a5c6d7cd5,2520 - completed: hackage: saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 pantry-tree: - size: 5016 sha256: fdf4397f4b1ed7975f38d0b463eb6c9d206d0c85d157c41c19983e80b2005763 + size: 5016 original: hackage: saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 - completed: hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601 pantry-tree: - size: 1059 sha256: 2d647a17372e42bc54331cfb35f5a55a71e6854dac8299b7ed6a1c69ae12734d + size: 1059 original: hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601 snapshots: - completed: + sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0 size: 585393 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/0.yaml - sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0 original: lts-18.0 From 9b9370fed0f55098163b55d88aea5fd55ffd736c Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Dec 2023 15:06:39 +0000 Subject: [PATCH 002/178] feat(auth): WIP authorization function --- src/Auth/OAuth2.hs | 9 ++--- src/Foundation/Types.hs | 18 +++++++++- src/Foundation/Yesod/Auth.hs | 67 +++++++++++++++++++++++++----------- 3 files changed, 69 insertions(+), 25 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 30a75a206..9b4efdd5d 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Auth.OAuth2 -( OAuthUserException(..) +( AzureUserException(..) , oauth2MockServer , mockPluginName ) where @@ -18,11 +18,12 @@ import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2.Prelude -data OAuthUserException = OAuthUserError - | OAuthUserAmbiguous -- TODO +data AzureUserException = AzureUserError + | AzureUserNoResult + | AzureUserAmbiguous -- TODO deriving (Show, Eq, Generic) -instance Exception OAuthUserException +instance Exception AzureUserException ---------------------------------------- ---- OAuth2 development auth plugin ---- diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index 786b943b0..252c1be26 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -6,6 +6,9 @@ module Foundation.Types ( UpsertCampusUserMode(..) , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser , _upsertCampusUserIdent + , UpsertAzureUserMode(..) + , _UpsertAzureUserLoginOAuth, _UpsertAzureUserLoginDummy, _UpsertAzureUserLoginOther, _UpsertAzureUserOAuthSync, _UpsertAzureUserGuessUser + , _upsertAzureUserIdent ) where import Import.NoFoundation @@ -21,3 +24,16 @@ data UpsertCampusUserMode makeLenses_ ''UpsertCampusUserMode makePrisms ''UpsertCampusUserMode + + +-- Azure users logging in via OAuth2 +data UpsertAzureUserMode + = UpsertAzureUserLoginOAuth + | UpsertAzureUserLoginDummy { upsertAzureUserIdent :: UserIdent } + | UpsertAzureUserLoginOther { upsertAzureUserIdent :: UserIdent } + | UpsertAzureUserOAuthSync { upsertAzureUserIdent :: UserIdent } + | UpsertAzureUserGuessUser + deriving (Eq, Ord, Read, Show, Generic) + +makeLenses_ ''UpsertAzureUserMode +makePrisms ''UpsertAzureUserMode diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index f394ee1f3..d01605495 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -25,6 +25,7 @@ import Foundation.Authorization (AuthorizationCacheKey(..)) import Yesod.Auth.Message import Auth.LDAP +import Auth.OAuth2 import Auth.PWHash (apHash) import Auth.Dummy (apDummy) @@ -122,22 +123,22 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend -> acceptExisting --- | Authentication via OAuth 2 +-- | Authentication via AzureADv2 / OAuth 2 oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) , YesodAuth UniWorX, UserId ~ AuthId UniWorX ) => Creds UniWorX -> m (AuthenticationResult UniWorX) oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do - $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" now <- liftIO getCurrentTime let uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertCampusUserMode -- TODO adjust do OAuth + upsertMode = creds ^? _upsertAzureUserMode - isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode + isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server + isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode excRecovery res | isDummy || isOther @@ -152,18 +153,18 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend excHandlers = [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + AzureUserNoResult -> do + $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + AzureUserAmbiguous -> do + $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do - $logErrorS "LDAP" $ tshow err + $logErrorS "OAuth" $ tshow err mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError - , C.Handler $ \(cExc :: CampusUserConversionException) -> do - $logErrorS "LDAP" $ tshow cExc + excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from? + , C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not? + $logErrorS "OAuth" $ tshow cExc mr <- getMessageRender excRecovery . ServerError $ mr cExc ] @@ -181,12 +182,15 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - pool <- getsYesod $ view _appLdapPool {-(case credsPlugin of - "azureadv2" -> getsYesod $ view _appLdapPool -- TODO - mockPluginName -> getsYesod $ view _appLdapPool -- TODO - _ -> error "undefined" -- TODO - )-} + $logDebugS "oauth" $ tshow Creds{..} + -- TODO look user up in DB + -- If not in DB then put (maybe prompt for email) + -- If in DB but first time oauth then prompt for password & update entry + -- Now user should be in DB -> authenticated + flip catches excHandlers $ case upsertMode of + Just upsertMode' -> error $ show upsertMode' --TODO + Nothing -> error "nothing" --TODO + {-pool <- getsYesod $ view _appLdapPool flip catches excHandlers $ case pool of Just ldapPool | Just upsertMode' <- upsertMode -> do @@ -194,7 +198,7 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData _other - -> acceptExisting + -> acceptExisting-} @@ -231,6 +235,29 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash + +_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode +_upsertAzureUserMode mMode cs@Creds{..} + | credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent) + | credsPlugin == "azureadv2" = setMode <$> mMode UpsertAzureUserLoginOAuth + | otherwise = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent) + where + setMode UpsertAzureUserLoginOAuth + = cs{ credsPlugin = "azureadv2" } + setMode (UpsertAzureUserLoginDummy ident) + = cs{ credsPlugin = mockPluginName + , credsIdent = CI.original ident + } + setMode (UpsertAzureUserLoginOther ident) + = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2") + , credsIdent = CI.original ident + } + setMode _ = cs + + defaultOther = apHash + + + ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) ldapLookupAndUpsert ident = getsYesod (view _appLdapPool) >>= \case From 44d082f8b95ad1b2d1ee0e9ce71d84dfbcd23df4 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Dec 2023 23:23:44 +0000 Subject: [PATCH 003/178] feat(auth): added azure & mock server to login widget --- src/Application.hs | 6 +++--- templates/login.hamlet | 10 +++++++++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index c6f2cb68c..8b9a21739 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -326,12 +326,12 @@ makeFoundation appSettings''@AppSettings{..} = do appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool - mAzureTenantID <- liftIO $ (fmap Text.pack) <$> lookupEnv "AZURE_ADV2_TENANT_ID" + mAzureTenantID <- liftIO $ (fmap Text.pack) <$> (return $ Just "123") -- lookupEnv "AZURE_ADV2_TENANT_ID" let -- Auth Plugins tenantID = fromMaybe (error "Tenant ID mising") mAzureTenantID loadPlugin p prefix = do -- Loads given YesodAuthPlugin - mID <- (fmap Text.pack) <$> (lookupEnv $ prefix ++ "_CLIENT_ID") - mSecret <- (fmap Text.pack) <$> (lookupEnv $ prefix ++ "_CLIENT_SECRET") + mID <- (fmap Text.pack) <$> (return $ Just "UWX") -- (lookupEnv $ prefix ++ "_CLIENT_ID") + mSecret <- (fmap Text.pack) <$> (return $ Just prefix) -- (lookupEnv $ prefix ++ "_CLIENT_SECRET") let mArgs = (,) <$> mID <*> mSecret guard $ isJust mArgs return . uncurry p $ fromJust mArgs diff --git a/templates/login.hamlet b/templates/login.hamlet index 19539af3f..7c1483d65 100644 --- a/templates/login.hamlet +++ b/templates/login.hamlet @@ -5,7 +5,15 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $forall AuthPlugin{apName, apLogin} <- plugins - $if apName == "LDAP" + $if apName == "azureadv2" +
+

Azure + ^{apLogin toParent} + $elseif apName == "uniworx_dev" +
+

_{MsgDummyLoginTitle} + ^{apLogin toParent} + $elseif apName == "LDAP"

_{MsgLDAPLoginTitle} ^{apLogin toParent} From cf89722c7fd47c0d0202bbaf44779ca847f18c61 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 4 Dec 2023 00:32:01 +0000 Subject: [PATCH 004/178] chore(auth): enabled ldap lookup for oauth2 creds --- src/Foundation/Instances.hs | 4 +++- src/Foundation/Yesod/Auth.hs | 36 +++++++++++++++++++++++------------- 2 files changed, 26 insertions(+), 14 deletions(-) diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 0b3e23892..79fefdccf 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -139,7 +139,9 @@ instance YesodAuth UniWorX where setTitleI MsgLoginTitle $(widgetFile "login") - authenticate = UniWorX.oAuthenticate -- UniWorX.authenticate + authenticate c@Creds{..} + | credsPlugin `elem` ["azureadv2", "uniworx_dev"] = UniWorX.oAuthenticate c + | otherwise = UniWorX.authenticate c authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes [ flip campusLogin campusUserFailoverMode <$> appLdapPool diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index d01605495..2bd046479 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -182,23 +182,17 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "oauth" $ tshow Creds{..} - -- TODO look user up in DB - -- If not in DB then put (maybe prompt for email) - -- If in DB but first time oauth then prompt for password & update entry - -- Now user should be in DB -> authenticated - flip catches excHandlers $ case upsertMode of - Just upsertMode' -> error $ show upsertMode' --TODO - Nothing -> error "nothing" --TODO - {-pool <- getsYesod $ view _appLdapPool + $logDebugS "oauth" $ tshow creds + -- TODO If user not in DB then put + pool <- getsYesod $ view _appLdapPool flip catches excHandlers $ case pool of Just ldapPool | Just upsertMode' <- upsertMode -> do - ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} - $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData + ldapData <- campusUser ldapPool campusUserFailoverMode creds + $logDebugS "OAuth" $ "Successful LDAP lookup of Azure user: " <> tshow ldapData + Authenticated . entityKey <$> upsertAzureUser upsertMode' ldapData _other - -> acceptExisting-} + -> acceptExisting @@ -267,6 +261,22 @@ ldapLookupAndUpsert ident = Nothing -> throwM CampusUserNoResult Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse + +upsertAzureUser :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertAzureUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -- TODO UpsertAzureUserMode is probably redundant +upsertAzureUser upsertMode = upsertCampusUser (toCampus upsertMode) + where + toCampus :: UpsertAzureUserMode -> UpsertCampusUserMode + toCampus UpsertAzureUserLoginOAuth = UpsertCampusUserLoginLdap + toCampus (UpsertAzureUserLoginDummy u) = UpsertCampusUserLoginDummy u + toCampus (UpsertAzureUserLoginOther u) = UpsertCampusUserLoginOther u + toCampus (UpsertAzureUserOAuthSync u) = UpsertCampusUserLdapSync u + toCampus UpsertAzureUserGuessUser = UpsertCampusUserGuessUser + + {- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP! upsertCampusUserByCn :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX From 5c4f742745546d50e0fc706b96d47f703af638a8 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 13 Dec 2023 16:36:52 +0000 Subject: [PATCH 005/178] chore(admin): add basic admin route stub and navigation for response inspection --- .../utils/navigation/menu/de-de-formal.msg | 3 +- .../uniworx/utils/navigation/menu/en-eu.msg | 3 +- routes | 3 +- src/Foundation/Navigation.hs | 9 ++++ src/Foundation/Routes.hs | 2 +- src/Handler/Admin.hs | 3 +- src/Handler/Admin/OAuth2.hs | 48 +++++++++++++++++++ 7 files changed, 66 insertions(+), 5 deletions(-) create mode 100644 src/Handler/Admin/OAuth2.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 502f3d09f..78e095b6d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -141,7 +141,8 @@ MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle MenuAvsSynchError: AVS Problemübersicht -MenuLdap: LDAP Schnittstelle +MenuLdap !ident-ok: LDAP +MenuOAuth2 !ident-ok: OAuth2 MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 9fcb4b2a6..bb085c38e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -141,7 +141,8 @@ MenuSap: SAP Interface MenuAvs: AVS Interface MenuAvsSynchError: AVS Problem Overview -MenuLdap: LDAP Interface +MenuLdap: LDAP +MenuOAuth2: OAuth2 MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter diff --git a/routes b/routes index 3f30c960a..2376c33af 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -70,6 +70,7 @@ /admin/avs AdminAvsR GET POST /admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST +/admin/oauth2 AdminOAuth2R GET POST /admin/problems AdminProblemsR GET /admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-avs-id ProblemWithoutAvsId GET diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index ce7d466f4..bf486ed22 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -116,6 +116,7 @@ breadcrumb AdminJobsR = i18nCrumb MsgBreadcrumbAdminJobs $ Just breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR +breadcrumb AdminOAuth2R = i18nCrumb MsgMenuOAuth2 $ Just AdminR breadcrumb AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminProblemsR @@ -861,6 +862,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , NavLink + { navLabel = MsgMenuOAuth2 + , navRoute = AdminOAuth2R + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } ] } , return NavHeaderContainer diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 454be37a6..e7f7ba32b 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -9,7 +9,7 @@ module Foundation.Routes ( module Foundation.Routes.Definitions , module Foundation.Routes ) where - + import Import.NoFoundation import Foundation.Type diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 2b9f17857..a64620899 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -31,6 +31,7 @@ import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Ldap as Handler.Admin +import Handler.Admin.OAuth2 as Handler.Admin getAdminR :: Handler Html diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs new file mode 100644 index 000000000..27a29b461 --- /dev/null +++ b/src/Handler/Admin/OAuth2.hs @@ -0,0 +1,48 @@ +-- SPDX-FileCopyrightText: 2023 Sarah Vaupel +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Admin.OAuth2 + ( getAdminOAuth2R + , postAdminOAuth2R + ) where + +import Import +-- import qualified Data.CaseInsensitive as CI +-- import qualified Data.Text as Text +-- import Handler.Utils + + +getAdminOAuth2R, postAdminOAuth2R :: Handler Html +getAdminOAuth2R = postAdminOAuth2R +postAdminOAuth2R = error "postAdminOAuth2R not yet implemented" +-- ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> +-- flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing +-- +-- let procFormPerson :: Text -> Handler (Maybe ()) +-- procFormPerson lid = error "TODO" +-- +-- +-- ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> +-- flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing +-- let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) +-- procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) +-- mbLdapUpsert <- formResultMaybe uresult procFormUpsert +-- +-- +-- actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute +-- siteLayoutMsg MsgMenuLdap $ do +-- setTitleI MsgMenuLdap +-- let personForm = wrapForm pwidget def +-- { formAction = Just $ SomeRoute actionUrl +-- , formEncoding = penctype +-- } +-- upsertForm = wrapForm uwidget def +-- { formAction = Just $ SomeRoute actionUrl +-- , formEncoding = uenctype +-- } +-- presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) +-- presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) +-- +-- -- TODO: use i18nWidgetFile instead if this is to become permanent +-- $(widgetFile "ldap") From ce8aa849f8548712a0d4a8586a825d48ad23134e Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 18 Dec 2023 00:56:50 +0000 Subject: [PATCH 006/178] chore(admin): oauth2 admin form identifiers --- src/Handler/Admin/OAuth2.hs | 61 ++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs index 27a29b461..cf99ab5cf 100644 --- a/src/Handler/Admin/OAuth2.hs +++ b/src/Handler/Admin/OAuth2.hs @@ -15,34 +15,33 @@ import Import getAdminOAuth2R, postAdminOAuth2R :: Handler Html getAdminOAuth2R = postAdminOAuth2R -postAdminOAuth2R = error "postAdminOAuth2R not yet implemented" --- ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> --- flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing --- --- let procFormPerson :: Text -> Handler (Maybe ()) --- procFormPerson lid = error "TODO" --- --- --- ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> --- flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing --- let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) --- procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) --- mbLdapUpsert <- formResultMaybe uresult procFormUpsert --- --- --- actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute --- siteLayoutMsg MsgMenuLdap $ do --- setTitleI MsgMenuLdap --- let personForm = wrapForm pwidget def --- { formAction = Just $ SomeRoute actionUrl --- , formEncoding = penctype --- } --- upsertForm = wrapForm uwidget def --- { formAction = Just $ SomeRoute actionUrl --- , formEncoding = uenctype --- } --- presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) --- presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) --- --- -- TODO: use i18nWidgetFile instead if this is to become permanent --- $(widgetFile "ldap") +postAdminOAuth2R = + ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> + flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + + let procFormPerson :: Text -> Handler (Maybe ()) + procFormPerson lid = error "TODO" + + ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> + flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) + procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) + mbLdapUpsert <- formResultMaybe uresult procFormUpsert + + + actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute + siteLayoutMsg MsgMenuLdap $ do + setTitleI MsgMenuLdap + let personForm = wrapForm pwidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = penctype + } + upsertForm = wrapForm uwidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = uenctype + } + presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) + presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) + + -- TODO: use i18nWidgetFile instead if this is to become permanent + $(widgetFile "oauth2") From a67697d159358d276aefb1cfb24fce70e32ce3e6 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 18 Dec 2023 02:58:14 +0000 Subject: [PATCH 007/178] chore(admin): added oauth2 handling widget --- src/Handler/Admin/OAuth2.hs | 46 +++++++++++++++++++++---------------- templates/oauth2.hamlet | 18 +++++++++++++++ 2 files changed, 44 insertions(+), 20 deletions(-) create mode 100644 templates/oauth2.hamlet diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs index cf99ab5cf..fdd8b8f63 100644 --- a/src/Handler/Admin/OAuth2.hs +++ b/src/Handler/Admin/OAuth2.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Sarah Vaupel +-- SPDX-FileCopyrightText: 2023 Sarah Vaupel ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,39 +9,45 @@ module Handler.Admin.OAuth2 import Import -- import qualified Data.CaseInsensitive as CI --- import qualified Data.Text as Text --- import Handler.Utils +import Data.Text() +--import qualified Data.Text as Text +--import qualified Data.Text.Encoding as Text +--import Foundation.Yesod.Auth (CampusUserConversionException()) +import Handler.Utils getAdminOAuth2R, postAdminOAuth2R :: Handler Html getAdminOAuth2R = postAdminOAuth2R -postAdminOAuth2R = +postAdminOAuth2R = do ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing - let procFormPerson :: Text -> Handler (Maybe ()) - procFormPerson lid = error "TODO" + let procFormPerson :: Text -> Handler (Maybe Text) + procFormPerson lid = return . Just $ "Mock reply for id " <> lid + -- TODO implement oauth query + mOAuth2Data <- formResultMaybe presult procFormPerson - ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> - flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing - let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) - procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) - mbLdapUpsert <- formResultMaybe uresult procFormUpsert + --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> + -- flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + + --let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) + -- procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) + --mbLdapUpsert <- formResultMaybe uresult procFormUpsert - actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute - siteLayoutMsg MsgMenuLdap $ do - setTitleI MsgMenuLdap + actionUrl <- fromMaybe AdminOAuth2R <$> getCurrentRoute + siteLayoutMsg MsgMenuOAuth2 $ do + setTitleI MsgMenuOAuth2 let personForm = wrapForm pwidget def { formAction = Just $ SomeRoute actionUrl , formEncoding = penctype } - upsertForm = wrapForm uwidget def - { formAction = Just $ SomeRoute actionUrl - , formEncoding = uenctype - } - presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) - presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) + --upsertForm = wrapForm uwidget def + -- { formAction = Just $ SomeRoute actionUrl + -- , formEncoding = uenctype + -- } + --presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) + --presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) -- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "oauth2") diff --git a/templates/oauth2.hamlet b/templates/oauth2.hamlet new file mode 100644 index 000000000..23030ebd6 --- /dev/null +++ b/templates/oauth2.hamlet @@ -0,0 +1,18 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 David Mosbach +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

+ OAuth2 User Search: + ^{personForm} + $maybe answers <- mOAuth2Data +

+ Antwort: # +
+
+ #{show answers} +
+ From 3e9e90ed86ee0c855b0ab5cd7287f825bbb700a4 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 12 Jan 2024 17:14:42 +0100 Subject: [PATCH 008/178] chore(settings): restructure Settings.hs; add OAuthConf to AppSettings --- src/Application.hs | 21 +- src/Jobs/Crontab.hs | 3 +- src/Settings.hs | 803 ++++++++++++++++++++++---------------------- 3 files changed, 424 insertions(+), 403 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 45f24768e..7d9172652 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -105,7 +105,7 @@ import Handler.Utils.Routes (classifyHandler) import qualified Data.Acid.Memory as Acid import qualified Web.ServerSession.Backend.Acid as Acid -import qualified Ldap.Client as Ldap (Host(Plain, Tls)) +-- import qualified Ldap.Client as Ldap (Host(Plain, Tls)) import qualified Network.Minio as Minio @@ -290,13 +290,13 @@ makeFoundation appSettings''@AppSettings{..} = do sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool' void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO - ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do - let ldapLabel = case ldapHost of - Ldap.Plain str -> pack str <> ":" <> tshow ldapPort - Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort - $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel - (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) - forM_ ldapPool $ registerFailoverMetrics "ldap" + -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do + -- let ldapLabel = case ldapHost of + -- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort + -- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort + -- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel + -- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) + -- forM_ ldapPool $ registerFailoverMetrics "ldap" -- Perform database migration using our application's logging settings. flip runReaderT tempFoundation $ @@ -376,7 +376,8 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + -- TODO: reimplement user db failover + let foundation = mkFoundation appSettings' sqlPool smtpPool Nothing appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logInfoS "setup" "*** DONE ***" @@ -615,6 +616,8 @@ appMain = runResourceT $ do foundation <- makeFoundation settings runAppLoggingT foundation $ do + $logErrorS "AppSettings" $ tshow settings + $logInfoS "setup" "Job-Handling" handleJobs foundation diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 72ae6a7c4..05725f0bf 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -310,7 +310,8 @@ determineCrontab = execWriterT $ do return (nextEpoch, nextInterval, nextIntervalTime, numIntervals) if - | is _Just appLdapConf + -- TODO: generalize user sync job to oauth + | is _Just appUserDbConf , Just syncWithin <- appSynchroniseLdapUsersWithin , Just cInterval <- appJobCronInterval -> do diff --git a/src/Settings.hs b/src/Settings.hs index e3fcc6105..96a5eb4da 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -84,6 +84,392 @@ import Utils.Lens.TH import qualified Data.Set as Set +data JobMode = JobsLocal { jobsAcceptOffload :: Bool } + | JobsOffload + | JobsDrop + { jobsAcceptOffload :: Bool + , jobsWriteFakeLastExec :: Bool + } + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Hashable) + +data ApprootScope = ApprootUserGenerated | ApprootDefault + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + deriving anyclass (Universe, Finite, Hashable) + + +newtype ServerSessionSettings + = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a } + +instance Show ServerSessionSettings where + showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _" + +data UserDefaultConf = UserDefaultConf + { userDefaultTheme :: Theme + , userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int + , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat + , userDefaultDownloadFiles :: Bool + , userDefaultWarningDays :: NominalDiffTime + , userDefaultShowSex :: Bool + , userDefaultExamOfficeGetSynced :: Bool + , userDefaultExamOfficeGetLabels :: Bool + , userDefaultPrefersPostal :: Bool + } deriving (Show) + +data PWHashConf = PWHashConf + { pwHashAlgorithm :: PWHashAlgorithm + , pwHashStrength :: Int + } + +instance Show PWHashConf where + show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }" + +instance FromJSON PWHashConf where + parseJSON = withObject "PWHashConf" $ \o -> do + pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text + pwHashAlgorithm <- if + | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1 + | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2 + | otherwise -> fail "Unsupported hash algorithm" + pwHashStrength <- o .: "strength" + + return PWHashConf{..} + +data ResourcePoolConf = ResourcePoolConf + { poolStripes :: Int + , poolTimeout :: NominalDiffTime + , poolLimit :: Int + } deriving (Show) + +data LdapConf = LdapConf + { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber + , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password + , ldapBase :: Ldap.Dn + , ldapScope :: Ldap.Scope + , ldapTimeout :: NominalDiffTime + , ldapSearchTimeout :: Int32 + , ldapPool :: ResourcePoolConf + } deriving (Show) + +makeLenses_ ''LdapConf + +-- TODO: use better types +data OAuthConf = OAuthConf + { oauthClientId :: Text + , oauthCientSecret :: Text + , oauthTenantId :: Text + , oauthScopes :: Set Text + } deriving (Show) + +makeLenses_ ''OAuthConf + +data UserDbConf = UserDbLdap LdapConf | UserDbOAuth OAuthConf + deriving (Show) + +makePrisms ''UserDbConf + +data LmsConf = LmsConf + { lmsUploadHeader :: Bool + , lmsUploadDelimiter :: Maybe Char + , lmsDownloadHeader :: Bool + , lmsDownloadDelimiter :: Char + , lmsDownloadCrLf :: Bool + , lmsDeletionDays :: Int + } deriving (Show) + +data AvsConf = AvsConf + { avsHost :: String + , avsPort :: Int + , avsUser :: ByteString + , avsPass :: ByteString + } deriving (Show) + +data LprConf = LprConf + { lprHost :: String + , lprPort :: Int + , lprQueue:: String + } deriving (Show) + +data SmtpConf = SmtpConf + { smtpHost :: HaskellNet.HostName + , smtpPort :: HaskellNet.PortNumber + , smtpAuth :: Maybe SmtpAuthConf + , smtpSsl :: SmtpSslMode + , smtpPool :: ResourcePoolConf + } deriving (Show) + +data WidgetMemcachedConf = WidgetMemcachedConf + { widgetMemcachedConf :: MemcachedConf + , widgetMemcachedBaseUrl :: Text + } deriving (Show) + +data MemcachedConf = MemcachedConf + { memcachedConnectInfo :: Memcached.ConnectInfo + , memcachedExpiry :: Maybe NominalDiffTime + } deriving (Show) + +instance FromJSON Memcached.Auth where + parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw + +instance FromJSON MemcachedConf where + parseJSON = withObject "MemcachedConf" $ \o -> do + connectHost <- o .:? "host" .!= "" + connectPort <- o .: "port" + connectAuth <- o .: "auth" + numConnection <- o .: "limit" + connectionIdleTime <- o .: "timeout" + memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration" + + return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. } + +instance FromJSON WidgetMemcachedConf where + parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do + widgetMemcachedConf <- parseJSON v + widgetMemcachedBaseUrl <- o .:? "base-url" .!= "" + return WidgetMemcachedConf{..} + +data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls + deriving (Show) + +data SmtpAuthConf = SmtpAuthConf + { smtpAuthType :: HaskellNet.AuthType + , smtpAuthUsername :: HaskellNet.UserName + , smtpAuthPassword :: HaskellNet.Password + } deriving (Show) + +data TokenBucketConf = TokenBucketConf + { tokenBucketDepth :: Word64 + , tokenBucketInvRate :: NominalDiffTime + , tokenBucketInitialValue :: Int64 + } deriving (Eq, Ord, Show, Generic) + +data VerpMode = VerpNone + | Verp { verpPrefix :: Text, verpSeparator :: Char } + deriving (Eq, Show, Read, Generic) + +data ARCConf w = ARCConf + { arccMaximumGhost :: Int + , arccMaximumWeight :: w + } deriving (Eq, Ord, Read, Show, Generic) + +data PrewarmCacheConf = PrewarmCacheConf + { precMaximumWeight :: Int + , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@ + , precSteps :: Natural + , precMaxSpeedup :: Rational + } deriving (Eq, Ord, Read, Show, Generic) + +data SettingBotMitigation + = SettingBotMitigationOnlyLoggedInTableSorting + | SettingBotMitigationUnauthorizedFormHoneypots + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + deriving anyclass (Universe, Finite) + +data LegalExternal = LegalExternal + { externalLanguage :: Lang + , externalImprint :: Text + , externalDataProtection :: Text + , externalTermsOfUse :: Text + , externalPayments :: Text + } + deriving (Eq, Ord, Read, Show, Generic) +makeLenses_ ''LegalExternal + + +nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1 +pathPieceJSON ''ApprootScope +pathPieceJSONKey ''ApprootScope +pathPieceBinary ''ApprootScope +pathPieceHttpApiData ''ApprootScope + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue + } ''VerpMode + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''TokenBucketConf + +deriveFromJSON defaultOptions ''Ldap.Scope +deriveFromJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''UserDefaultConf + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + } ''JobMode + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ARCConf + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''PrewarmCacheConf + +makeLenses_ ''PrewarmCacheConf + +nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3 +pathPieceJSON ''SettingBotMitigation +pathPieceJSONKey ''SettingBotMitigation + +makePrisms ''JobMode +makeLenses_ ''JobMode + + +deriveFromJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''ResourcePoolConf + +instance FromJSON LdapConf where + parseJSON = withObject "LdapConf" $ \o -> do + ldapTls <- o .:? "tls" + tlsSettings <- case ldapTls :: Maybe String of + Just spec + | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings + | spec == "default" -> return $ Just Ldap.defaultTlsSettings + | spec == "none" -> return Nothing + | spec == "notls" -> return Nothing + | null spec -> return Nothing + Nothing -> return Nothing + _otherwise -> fail "Could not parse LDAP TLSSettings" + ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= "" + ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port" + ldapDn <- Ldap.Dn <$> o .:? "user" .!= "" + ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= "" + ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= "" + ldapScope <- o .: "scope" + ldapTimeout <- o .: "timeout" + ldapSearchTimeout <- o .: "search-timeout" + ldapPool <- o .: "pool" + return LdapConf{..} + +deriveFromJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''OAuthConf + +deriveFromJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "type" "config" + } ''UserDbConf + +instance FromJSON HaskellNet.PortNumber where + parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of + Just int -> return $ fromIntegral (int :: Word16) + Nothing -> fail "Expected whole number of plausible size to denote port" + +deriveFromJSON defaultOptions + { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack + , allNullaryToStringTag = True + } ''HaskellNet.AuthType + +instance FromJSON LmsConf where + parseJSON = withObject "LmsConf" $ \o -> do + lmsUploadHeader <- o .: "upload-header" + lmsUploadDelimiter <- o .:? "upload-delimiter" + lmsDownloadHeader <- o .: "download-header" + lmsDownloadDelimiter <- o .: "download-delimiter" + lmsDownloadCrLf <- o .: "download-cr-lf" + lmsDeletionDays <- o .: "deletion-days" + return LmsConf{..} + +makeLenses_ ''LmsConf + +instance FromJSON AvsConf where + parseJSON = withObject "AvsConf" $ \o -> do + avsHost <- o .: "host" + avsPort <- o .: "port" + avsUser <- o .: "user" + avsPass <- o .:? "pass" .!= "" + return AvsConf{..} + +instance FromJSON LprConf where + parseJSON = withObject "LprConf" $ \o -> do + lprHost <- o .: "host" + lprPort <- o .: "port" + lprQueue <- o .: "queue" + return LprConf{..} + +instance FromJSON SmtpConf where + parseJSON = withObject "SmtpConf" $ \o -> do + smtpHost <- o .:? "host" .!= "" + smtpPort <- o .: "port" + smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth" + smtpSsl <- o .: "ssl" + smtpPool <- o .: "pool" + return SmtpConf{..} + +deriveFromJSON + defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + , allNullaryToStringTag = True + } + ''SmtpSslMode + +instance FromJSON SmtpAuthConf where + parseJSON = withObject "SmtpAuthConf" $ \o -> do + smtpAuthType <- o .: "type" + smtpAuthUsername <- o .:? "user" .!= "" + smtpAuthPassword <- o .:? "pass" .!= "" + return SmtpAuthConf{..} + +instance FromJSON JwtEncoding where + parseJSON v@(String _) = JwsEncoding <$> parseJSON v + parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum + [ do + alg <- obj .: "alg" + return $ JwsEncoding alg + , do + alg <- obj .: "alg" + enc <- obj .: "enc" + return $ JweEncoding alg enc + ] + +instance FromJSON Minio.ConnectInfo where + parseJSON v@(String _) = fromString <$> parseJSON v + parseJSON v = flip (withObject "ConnectInfo") v $ \o -> do + connectHost <- o .:? "host" .!= "" + connectPort <- o .: "port" + connectAccessKey <- o .:? "access-key" .!= "" + connectSecretKey <- o .:? "secret-key" .!= "" + connectIsSecure <- o .: "is-secure" + connectRegion <- o .:? "region" .!= "" + connectAutoDiscoverRegion <- o .:? "auto-discover-region" .!= True + connectDisableTLSCertValidation <- o .:? "disable-cert-validation" .!= False + return Minio.ConnectInfo{..} + +instance FromJSON ServerSessionSettings where + parseJSON = withObject "ServerSession.State" $ \o -> do + idleTimeout <- o .:? "idle-timeout" + absoluteTimeout <- o .:? "absolute-timeout" + timeoutResolution <- o .:? "timeout-resolution" + persistentCookies <- o .:? "persistent-cookies" + return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes + [ pure $ ServerSession.setIdleTimeout idleTimeout + , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout + , pure $ ServerSession.setTimeoutResolution timeoutResolution + , ServerSession.setPersistentCookies <$> persistentCookies + ]) + +instance FromJSON LegalExternal where + parseJSON = withObject "LegalExternal" $ \o -> do + externalLanguage <- o .: "language" + externalImprint <- o .: "imprint" + externalDataProtection <- o .: "data-protection" + externalTermsOfUse<- o .: "terms-of-use" + externalPayments <- o .: "payments" + return LegalExternal{..} + +submissionBlacklist :: [Pattern] +submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist") + +personalisedSheetFilesCollatable :: Map Text Pattern +personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate") + + -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, -- theoretically even a database. @@ -96,7 +482,7 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool - , appLdapConf :: Maybe (PointedList LdapConf) + , appUserDbConf :: Maybe (PointedList UserDbConf) -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory @@ -254,365 +640,6 @@ data AppSettings = AppSettings } deriving Show - -data JobMode = JobsLocal { jobsAcceptOffload :: Bool } - | JobsOffload - | JobsDrop - { jobsAcceptOffload :: Bool - , jobsWriteFakeLastExec :: Bool - } - deriving (Eq, Ord, Read, Show, Generic) - deriving anyclass (Hashable) - -data ApprootScope = ApprootUserGenerated | ApprootDefault - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite, Hashable) - - -newtype ServerSessionSettings - = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a } - -instance Show ServerSessionSettings where - showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _" - -data UserDefaultConf = UserDefaultConf - { userDefaultTheme :: Theme - , userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int - , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat - , userDefaultDownloadFiles :: Bool - , userDefaultWarningDays :: NominalDiffTime - , userDefaultShowSex :: Bool - , userDefaultExamOfficeGetSynced :: Bool - , userDefaultExamOfficeGetLabels :: Bool - , userDefaultPrefersPostal :: Bool - } deriving (Show) - -data PWHashConf = PWHashConf - { pwHashAlgorithm :: PWHashAlgorithm - , pwHashStrength :: Int - } - -instance Show PWHashConf where - show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }" - -instance FromJSON PWHashConf where - parseJSON = withObject "PWHashConf" $ \o -> do - pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text - pwHashAlgorithm <- if - | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1 - | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2 - | otherwise -> fail "Unsupported hash algorithm" - pwHashStrength <- o .: "strength" - - return PWHashConf{..} - -data LdapConf = LdapConf - { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber - , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password - , ldapBase :: Ldap.Dn - , ldapScope :: Ldap.Scope - , ldapTimeout :: NominalDiffTime - , ldapSearchTimeout :: Int32 - , ldapPool :: ResourcePoolConf - } deriving (Show) - -data LmsConf = LmsConf - { lmsUploadHeader :: Bool - , lmsUploadDelimiter :: Maybe Char - , lmsDownloadHeader :: Bool - , lmsDownloadDelimiter :: Char - , lmsDownloadCrLf :: Bool - , lmsDeletionDays :: Int - } deriving (Show) - -data AvsConf = AvsConf - { avsHost :: String - , avsPort :: Int - , avsUser :: ByteString - , avsPass :: ByteString - } deriving (Show) - -data LprConf = LprConf - { lprHost :: String - , lprPort :: Int - , lprQueue:: String - } deriving (Show) - -data SmtpConf = SmtpConf - { smtpHost :: HaskellNet.HostName - , smtpPort :: HaskellNet.PortNumber - , smtpAuth :: Maybe SmtpAuthConf - , smtpSsl :: SmtpSslMode - , smtpPool :: ResourcePoolConf - } deriving (Show) - -data WidgetMemcachedConf = WidgetMemcachedConf - { widgetMemcachedConf :: MemcachedConf - , widgetMemcachedBaseUrl :: Text - } deriving (Show) - -data MemcachedConf = MemcachedConf - { memcachedConnectInfo :: Memcached.ConnectInfo - , memcachedExpiry :: Maybe NominalDiffTime - } deriving (Show) - -instance FromJSON Memcached.Auth where - parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw - -instance FromJSON MemcachedConf where - parseJSON = withObject "MemcachedConf" $ \o -> do - connectHost <- o .:? "host" .!= "" - connectPort <- o .: "port" - connectAuth <- o .: "auth" - numConnection <- o .: "limit" - connectionIdleTime <- o .: "timeout" - memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration" - - return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. } - -instance FromJSON WidgetMemcachedConf where - parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do - widgetMemcachedConf <- parseJSON v - widgetMemcachedBaseUrl <- o .:? "base-url" .!= "" - return WidgetMemcachedConf{..} - -data ResourcePoolConf = ResourcePoolConf - { poolStripes :: Int - , poolTimeout :: NominalDiffTime - , poolLimit :: Int - } deriving (Show) - -data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls - deriving (Show) - -data SmtpAuthConf = SmtpAuthConf - { smtpAuthType :: HaskellNet.AuthType - , smtpAuthUsername :: HaskellNet.UserName - , smtpAuthPassword :: HaskellNet.Password - } deriving (Show) - -data TokenBucketConf = TokenBucketConf - { tokenBucketDepth :: Word64 - , tokenBucketInvRate :: NominalDiffTime - , tokenBucketInitialValue :: Int64 - } deriving (Eq, Ord, Show, Generic) - -data VerpMode = VerpNone - | Verp { verpPrefix :: Text, verpSeparator :: Char } - deriving (Eq, Show, Read, Generic) - -data ARCConf w = ARCConf - { arccMaximumGhost :: Int - , arccMaximumWeight :: w - } deriving (Eq, Ord, Read, Show, Generic) - -data PrewarmCacheConf = PrewarmCacheConf - { precMaximumWeight :: Int - , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@ - , precSteps :: Natural - , precMaxSpeedup :: Rational - } deriving (Eq, Ord, Read, Show, Generic) - -data SettingBotMitigation - = SettingBotMitigationOnlyLoggedInTableSorting - | SettingBotMitigationUnauthorizedFormHoneypots - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite) - -data LegalExternal = LegalExternal - { externalLanguage :: Lang - , externalImprint :: Text - , externalDataProtection :: Text - , externalTermsOfUse :: Text - , externalPayments :: Text - } - deriving (Eq, Ord, Read, Show, Generic) -makeLenses_ ''LegalExternal - - -nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1 -pathPieceJSON ''ApprootScope -pathPieceJSONKey ''ApprootScope -pathPieceBinary ''ApprootScope -pathPieceHttpApiData ''ApprootScope - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , fieldLabelModifier = camelToPathPiece' 1 - , sumEncoding = UntaggedValue - } ''VerpMode - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 2 - } ''TokenBucketConf - -deriveFromJSON defaultOptions ''Ldap.Scope -deriveFromJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 2 - } ''UserDefaultConf - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - } ''JobMode - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''ARCConf - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''PrewarmCacheConf - -makeLenses_ ''PrewarmCacheConf - -nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3 -pathPieceJSON ''SettingBotMitigation -pathPieceJSONKey ''SettingBotMitigation - -makePrisms ''JobMode -makeLenses_ ''JobMode - - -instance FromJSON LdapConf where - parseJSON = withObject "LdapConf" $ \o -> do - ldapTls <- o .:? "tls" - tlsSettings <- case ldapTls :: Maybe String of - Just spec - | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings - | spec == "default" -> return $ Just Ldap.defaultTlsSettings - | spec == "none" -> return Nothing - | spec == "notls" -> return Nothing - | null spec -> return Nothing - Nothing -> return Nothing - _otherwise -> fail "Could not parse LDAP TLSSettings" - ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= "" - ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port" - ldapDn <- Ldap.Dn <$> o .:? "user" .!= "" - ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= "" - ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= "" - ldapScope <- o .: "scope" - ldapTimeout <- o .: "timeout" - ldapSearchTimeout <- o .: "search-timeout" - ldapPool <- o .: "pool" - return LdapConf{..} - -deriveFromJSON - defaultOptions - { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } - ''ResourcePoolConf - -instance FromJSON HaskellNet.PortNumber where - parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of - Just int -> return $ fromIntegral (int :: Word16) - Nothing -> fail "Expected whole number of plausible size to denote port" - -deriveFromJSON - defaultOptions - { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack - , allNullaryToStringTag = True - } - ''HaskellNet.AuthType - -instance FromJSON LmsConf where - parseJSON = withObject "LmsConf" $ \o -> do - lmsUploadHeader <- o .: "upload-header" - lmsUploadDelimiter <- o .:? "upload-delimiter" - lmsDownloadHeader <- o .: "download-header" - lmsDownloadDelimiter <- o .: "download-delimiter" - lmsDownloadCrLf <- o .: "download-cr-lf" - lmsDeletionDays <- o .: "deletion-days" - return LmsConf{..} - -makeLenses_ ''LmsConf - -instance FromJSON AvsConf where - parseJSON = withObject "AvsConf" $ \o -> do - avsHost <- o .: "host" - avsPort <- o .: "port" - avsUser <- o .: "user" - avsPass <- o .:? "pass" .!= "" - return AvsConf{..} - -instance FromJSON LprConf where - parseJSON = withObject "LprConf" $ \o -> do - lprHost <- o .: "host" - lprPort <- o .: "port" - lprQueue <- o .: "queue" - return LprConf{..} - -instance FromJSON SmtpConf where - parseJSON = withObject "SmtpConf" $ \o -> do - smtpHost <- o .:? "host" .!= "" - smtpPort <- o .: "port" - smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth" - smtpSsl <- o .: "ssl" - smtpPool <- o .: "pool" - return SmtpConf{..} - -deriveFromJSON - defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel - , allNullaryToStringTag = True - } - ''SmtpSslMode - -instance FromJSON SmtpAuthConf where - parseJSON = withObject "SmtpAuthConf" $ \o -> do - smtpAuthType <- o .: "type" - smtpAuthUsername <- o .:? "user" .!= "" - smtpAuthPassword <- o .:? "pass" .!= "" - return SmtpAuthConf{..} - -instance FromJSON JwtEncoding where - parseJSON v@(String _) = JwsEncoding <$> parseJSON v - parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum - [ do - alg <- obj .: "alg" - return $ JwsEncoding alg - , do - alg <- obj .: "alg" - enc <- obj .: "enc" - return $ JweEncoding alg enc - ] - -instance FromJSON Minio.ConnectInfo where - parseJSON v@(String _) = fromString <$> parseJSON v - parseJSON v = flip (withObject "ConnectInfo") v $ \o -> do - connectHost <- o .:? "host" .!= "" - connectPort <- o .: "port" - connectAccessKey <- o .:? "access-key" .!= "" - connectSecretKey <- o .:? "secret-key" .!= "" - connectIsSecure <- o .: "is-secure" - connectRegion <- o .:? "region" .!= "" - connectAutoDiscoverRegion <- o .:? "auto-discover-region" .!= True - connectDisableTLSCertValidation <- o .:? "disable-cert-validation" .!= False - return Minio.ConnectInfo{..} - - -instance FromJSON ServerSessionSettings where - parseJSON = withObject "ServerSession.State" $ \o -> do - idleTimeout <- o .:? "idle-timeout" - absoluteTimeout <- o .:? "absolute-timeout" - timeoutResolution <- o .:? "timeout-resolution" - persistentCookies <- o .:? "persistent-cookies" - return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes - [ pure $ ServerSession.setIdleTimeout idleTimeout - , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout - , pure $ ServerSession.setTimeoutResolution timeoutResolution - , ServerSession.setPersistentCookies <$> persistentCookies - ]) - -instance FromJSON LegalExternal where - parseJSON = withObject "LegalExternal" $ \o -> do - externalLanguage <- o .: "language" - externalImprint <- o .: "imprint" - externalDataProtection <- o .: "data-protection" - externalTermsOfUse<- o .: "terms-of-use" - externalPayments <- o .: "payments" - return LegalExternal{..} - instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -627,10 +654,11 @@ instance FromJSON AppSettings where appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" appAutoDbMigrate <- o .: "auto-db-migrate" - let nonEmptyHost LdapConf{..} = case ldapHost of + let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host - appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] + nonEmptyHost (UserDbOAuth OAuthConf{..}) = not $ or [ null oauthTenantId, null oauthClientId, null oauthCientSecret ] + appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-db" .!= [] appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" @@ -816,6 +844,26 @@ instance FromJSON AppSettings where makeClassy_ ''AppSettings +-- | Raw bytes at compile time of @config/settings.yml@ +configSettingsYmlBS :: ByteString +configSettingsYmlBS = $(embedFile configSettingsYml) + +-- | @config/settings.yml@, parsed to a @Value@. +configSettingsYmlValue :: Value +configSettingsYmlValue = either Exception.throw id + $ decodeEither' configSettingsYmlBS + +-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. +compileTimeAppSettings :: AppSettings +compileTimeAppSettings = + case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of + Aeson.Error e -> error e + Aeson.Success settings -> settings + +-- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile) +-- hamletFile' :: FilePath -> Q Exp +-- hamletFile' nameBase = hamletFile $ "templates" nameBase + -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. -- @@ -825,16 +873,6 @@ makeClassy_ ''AppSettings widgetFileSettings :: WidgetFileSettings widgetFileSettings = def - -submissionBlacklist :: [Pattern] -submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist") - -personalisedSheetFilesCollatable :: Map Text Pattern -personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate") - --- The rest of this file contains settings which rarely need changing by a --- user. - widgetFile :: String -> Q Exp #ifdef DEVELOPMENT widgetFile nameBase = do @@ -855,24 +893,3 @@ widgetFile | otherwise = widgetFileNoReload widgetFileSettings #endif - --- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile) --- hamletFile' :: FilePath -> Q Exp --- hamletFile' nameBase = hamletFile $ "templates" nameBase - - --- | Raw bytes at compile time of @config/settings.yml@ -configSettingsYmlBS :: ByteString -configSettingsYmlBS = $(embedFile configSettingsYml) - --- | @config/settings.yml@, parsed to a @Value@. -configSettingsYmlValue :: Value -configSettingsYmlValue = either Exception.throw id - $ decodeEither' configSettingsYmlBS - --- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. -compileTimeAppSettings :: AppSettings -compileTimeAppSettings = - case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of - Aeson.Error e -> error e - Aeson.Success settings -> settings From 5e85eae82539b1937a36a24b470d0e11e08cf127 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 12 Jan 2024 23:24:58 +0100 Subject: [PATCH 009/178] refactor(settings): move ResourcePool, Ldap and OAuth2 settings to separate modules --- src/Settings.hs | 78 ++++++------------------------------ src/Settings/Ldap.hs | 64 +++++++++++++++++++++++++++++ src/Settings/OAuth2.hs | 32 +++++++++++++++ src/Settings/ResourcePool.hs | 30 ++++++++++++++ 4 files changed, 138 insertions(+), 66 deletions(-) create mode 100644 src/Settings/Ldap.hs create mode 100644 src/Settings/OAuth2.hs create mode 100644 src/Settings/ResourcePool.hs diff --git a/src/Settings.hs b/src/Settings.hs index 96a5eb4da..3e1790b2e 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,10 +13,13 @@ module Settings ( module Settings , module Settings.Cluster - , module Settings.Mime , module Settings.Cookies + , module Settings.Ldap , module Settings.Log , module Settings.Locale + , module Settings.Mime + , module Settings.OAuth2 + , module Settings.ResourcePool ) where import Import.NoModel @@ -44,7 +47,6 @@ import qualified Data.Scientific as Scientific import Data.Word (Word16) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap @@ -56,11 +58,15 @@ import Network.Mail.Mime.Instances () import qualified Database.Memcached.Binary.Types as Memcached import Model + import Settings.Cluster -import Settings.Mime import Settings.Cookies +import Settings.Ldap import Settings.Log import Settings.Locale +import Settings.Mime +import Settings.OAuth2 +import Settings.ResourcePool import qualified System.FilePath as FilePath @@ -135,35 +141,8 @@ instance FromJSON PWHashConf where return PWHashConf{..} -data ResourcePoolConf = ResourcePoolConf - { poolStripes :: Int - , poolTimeout :: NominalDiffTime - , poolLimit :: Int - } deriving (Show) -data LdapConf = LdapConf - { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber - , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password - , ldapBase :: Ldap.Dn - , ldapScope :: Ldap.Scope - , ldapTimeout :: NominalDiffTime - , ldapSearchTimeout :: Int32 - , ldapPool :: ResourcePoolConf - } deriving (Show) - -makeLenses_ ''LdapConf - --- TODO: use better types -data OAuthConf = OAuthConf - { oauthClientId :: Text - , oauthCientSecret :: Text - , oauthTenantId :: Text - , oauthScopes :: Set Text - } deriving (Show) - -makeLenses_ ''OAuthConf - -data UserDbConf = UserDbLdap LdapConf | UserDbOAuth OAuthConf +data UserDbConf = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf deriving (Show) makePrisms ''UserDbConf @@ -292,7 +271,6 @@ deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } ''TokenBucketConf -deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } ''UserDefaultConf @@ -319,38 +297,6 @@ pathPieceJSONKey ''SettingBotMitigation makePrisms ''JobMode makeLenses_ ''JobMode - -deriveFromJSON defaultOptions - { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } ''ResourcePoolConf - -instance FromJSON LdapConf where - parseJSON = withObject "LdapConf" $ \o -> do - ldapTls <- o .:? "tls" - tlsSettings <- case ldapTls :: Maybe String of - Just spec - | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings - | spec == "default" -> return $ Just Ldap.defaultTlsSettings - | spec == "none" -> return Nothing - | spec == "notls" -> return Nothing - | null spec -> return Nothing - Nothing -> return Nothing - _otherwise -> fail "Could not parse LDAP TLSSettings" - ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= "" - ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port" - ldapDn <- Ldap.Dn <$> o .:? "user" .!= "" - ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= "" - ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= "" - ldapScope <- o .: "scope" - ldapTimeout <- o .: "timeout" - ldapSearchTimeout <- o .: "search-timeout" - ldapPool <- o .: "pool" - return LdapConf{..} - -deriveFromJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''OAuthConf - deriveFromJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 , sumEncoding = TaggedObject "type" "config" @@ -657,7 +603,7 @@ instance FromJSON AppSettings where let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host - nonEmptyHost (UserDbOAuth OAuthConf{..}) = not $ or [ null oauthTenantId, null oauthClientId, null oauthCientSecret ] + nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-db" .!= [] appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs new file mode 100644 index 000000000..0a3bdea23 --- /dev/null +++ b/src/Settings/Ldap.hs @@ -0,0 +1,64 @@ +-- SPDX-FileCopyrightText: 2024 Sarah Vaupel +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Settings.Ldap + ( LdapConf(..) + , _ldapHost, _ldapDn, _ldapBase, _ldapScope, _ldapTimeout, _ldapSearchTimeout, _ldapPool + ) where + +import ClassyPrelude + +import Settings.ResourcePool +import Utils.Lens.TH + +import Control.Monad.Fail (fail) + +import Data.Aeson +import Data.Aeson.TH +import qualified Data.Text.Encoding as Text +import Data.Time.Clock + +import qualified Ldap.Client as Ldap + + +data LdapConf = LdapConf + { ldapHost :: Ldap.Host + , ldapPort :: Ldap.PortNumber + , ldapDn :: Ldap.Dn + , ldapPassword :: Ldap.Password + , ldapBase :: Ldap.Dn + , ldapScope :: Ldap.Scope + , ldapTimeout :: NominalDiffTime + , ldapSearchTimeout :: Int32 + , ldapPool :: ResourcePoolConf + } deriving (Show) + +makeLenses_ ''LdapConf + +deriveFromJSON defaultOptions ''Ldap.Scope + +instance FromJSON LdapConf where + parseJSON = withObject "LdapConf" $ \o -> do + ldapTls <- o .:? "tls" + tlsSettings <- case ldapTls :: Maybe String of + Just spec + | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings + | spec == "default" -> return $ Just Ldap.defaultTlsSettings + | spec == "none" -> return Nothing + | spec == "notls" -> return Nothing + | null spec -> return Nothing + Nothing -> return Nothing + _otherwise -> fail "Could not parse LDAP TLSSettings" + ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= "" + ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port" + ldapDn <- Ldap.Dn <$> o .:? "user" .!= "" + ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= "" + ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= "" + ldapScope <- o .: "scope" + ldapTimeout <- o .: "timeout" + ldapSearchTimeout <- o .: "search-timeout" + ldapPool <- o .: "pool" + return LdapConf{..} diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs new file mode 100644 index 000000000..53877b0dd --- /dev/null +++ b/src/Settings/OAuth2.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2024 Sarah Vaupel +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Settings.OAuth2 + ( OAuth2Conf(..) + , _oauth2ClientId, _oauth2ClientSecret, _oauth2TenantId, _oauth2Scopes + ) where + +import ClassyPrelude + +import Utils.Lens.TH +import Utils.PathPiece (camelToPathPiece') + +import Data.Aeson +import Data.Aeson.TH + + + +-- TODO: use better types +data OAuth2Conf = OAuth2Conf + { oauth2ClientId :: Text + , oauth2ClientSecret :: Text + , oauth2TenantId :: Text + , oauth2Scopes :: Set Text + } deriving (Show) + +makeLenses_ ''OAuth2Conf + +deriveFromJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''OAuth2Conf diff --git a/src/Settings/ResourcePool.hs b/src/Settings/ResourcePool.hs new file mode 100644 index 000000000..df3fa3156 --- /dev/null +++ b/src/Settings/ResourcePool.hs @@ -0,0 +1,30 @@ +-- SPDX-FileCopyrightText: 2024 Sarah Vaupel +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Settings.ResourcePool + ( ResourcePoolConf(..) + , _poolStripes, _poolTimeout, _poolLimit + ) where + +import ClassyPrelude + +import Utils.Lens.TH +import Utils.PathPiece (camelToPathPiece') + +import Data.Aeson +import Data.Aeson.TH +import Data.Time.Clock + + +data ResourcePoolConf = ResourcePoolConf + { poolStripes :: Int + , poolTimeout :: NominalDiffTime + , poolLimit :: Int + } deriving (Show) + +makeLenses_ ''ResourcePoolConf + +deriveFromJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ResourcePoolConf From 7ca12d064da979f840977c70947b8e65f379abb2 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 13 Jan 2024 00:40:57 +0100 Subject: [PATCH 010/178] refactor(settings): enhance field names --- src/Settings.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Settings.hs b/src/Settings.hs index 3e1790b2e..753dd56d0 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -299,7 +299,7 @@ makeLenses_ ''JobMode deriveFromJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 - , sumEncoding = TaggedObject "type" "config" + , sumEncoding = TaggedObject "protocol" "config" } ''UserDbConf instance FromJSON HaskellNet.PortNumber where @@ -604,7 +604,7 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] - appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-db" .!= [] + appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-databases" .!= [] appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" From 7946e046e29da274aec29ae312346a6ac9dfe759 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 13 Jan 2024 00:42:25 +0100 Subject: [PATCH 011/178] chore(settings): update settings.yml --- config/settings.yml | 40 +++++++++++++++++++++++++--------------- 1 file changed, 25 insertions(+), 15 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 602c9c0e2..e759be67a 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -131,20 +131,30 @@ database: auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' -ldap: - - host: "_env:LDAPHOST:" - tls: "_env:LDAPTLS:" - port: "_env:LDAPPORT:389" - user: "_env:LDAPUSER:" - pass: "_env:LDAPPASS:" - baseDN: "_env:LDAPBASE:" - scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" - search-timeout: "_env:LDAPSEARCHTIME:5" - pool: - stripes: "_env:LDAPSTRIPES:1" - timeout: "_env:LDAPTIMEOUT:20" - limit: "_env:LDAPLIMIT:10" +# External databases used for authentication and user data lookup +# If the first user database in the list is unreachable, the application will perform a failover to the next list entry, etc. +user-databases: + - protocol: "oauth2" + config: + client-id: "_env:OAUTH2CLIENTID:" + client-secret: "_env:OAUTH2CLIENTSECRET:" + tenant-id: "_env:OAUTH2TENANTID:" + scopes: "_env:OAUTH2SCOPES:" + - protocol: "ldap" + config: + host: "_env:LDAPHOST:" + tls: "_env:LDAPTLS:" + port: "_env:LDAPPORT:389" + user: "_env:LDAPUSER:" + pass: "_env:LDAPPASS:" + baseDN: "_env:LDAPBASE:" + scope: "_env:LDAPSCOPE:WholeSubtree" + timeout: "_env:LDAPTIMEOUT:5" + search-timeout: "_env:LDAPSEARCHTIME:5" + pool: + stripes: "_env:LDAPSTRIPES:1" + timeout: "_env:LDAPTIMEOUT:20" + limit: "_env:LDAPLIMIT:10" ldap-re-test-failover: 60 From 31f657a15f9a3614e83b719d67ac4ce25e021cb9 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 13 Jan 2024 01:14:54 +0100 Subject: [PATCH 012/178] chore(settings): fix oauth2 config json parsers --- src/Settings.hs | 2 +- src/Settings/OAuth2.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Settings.hs b/src/Settings.hs index 753dd56d0..8c89aa3ce 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -298,7 +298,7 @@ makePrisms ''JobMode makeLenses_ ''JobMode deriveFromJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 2 + { constructorTagModifier = toLower . dropPrefix "UserDb" , sumEncoding = TaggedObject "protocol" "config" } ''UserDbConf diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs index 53877b0dd..98e1908b4 100644 --- a/src/Settings/OAuth2.hs +++ b/src/Settings/OAuth2.hs @@ -10,7 +10,7 @@ module Settings.OAuth2 import ClassyPrelude import Utils.Lens.TH -import Utils.PathPiece (camelToPathPiece') +import Utils.PathPiece (camelToPathPiece) import Data.Aeson import Data.Aeson.TH @@ -28,5 +28,5 @@ data OAuth2Conf = OAuth2Conf makeLenses_ ''OAuth2Conf deriveFromJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 + { fieldLabelModifier = camelToPathPiece . dropPrefix "oauth2" } ''OAuth2Conf From 35902daff684aef5780ced87c6df8b0ffb991dcf Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 13 Jan 2024 01:19:58 +0100 Subject: [PATCH 013/178] chore(settings): add default value for oauth2 scopes in yaml --- config/settings.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/settings.yml b/config/settings.yml index e759be67a..3a56e561d 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -139,7 +139,7 @@ user-databases: client-id: "_env:OAUTH2CLIENTID:" client-secret: "_env:OAUTH2CLIENTSECRET:" tenant-id: "_env:OAUTH2TENANTID:" - scopes: "_env:OAUTH2SCOPES:" + scopes: "_env:OAUTH2SCOPES:[]" - protocol: "ldap" config: host: "_env:LDAPHOST:" From 9f299c854c9d2d2f1b1127c85a31b787f85fa210 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 19 Jan 2024 14:53:00 +0100 Subject: [PATCH 014/178] chore(settings)!: rename userdb app settings --- config/settings.yml | 10 +++++----- src/Settings.hs | 18 ++++++++---------- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 3a56e561d..dd2e31924 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -81,9 +81,6 @@ health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2" health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2" -synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600" # 14 Tage in Sekunden -synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600" # jede Stunde - synchronise-avs-users-within: "_env:SYNCHRONISE_AVS_WITHIN:5702400" # alle 66 Tage synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 Stunden @@ -133,7 +130,7 @@ auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' # External databases used for authentication and user data lookup # If the first user database in the list is unreachable, the application will perform a failover to the next list entry, etc. -user-databases: +user-database: - protocol: "oauth2" config: client-id: "_env:OAUTH2CLIENTID:" @@ -156,7 +153,10 @@ user-databases: timeout: "_env:LDAPTIMEOUT:20" limit: "_env:LDAPLIMIT:10" -ldap-re-test-failover: 60 +userdb-retest-failover: 60 +userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden +userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600" # jede Stunde + lms-direct: upload-header: "_env:LMSUPLOADHEADER:true" diff --git a/src/Settings.hs b/src/Settings.hs index 8c89aa3ce..2d811865c 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -494,14 +494,13 @@ data AppSettings = AppSettings , appHealthCheckHTTPReachableTimeout :: NominalDiffTime , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime - , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime - , appSynchroniseLdapUsersInterval :: NominalDiffTime + , appUserdbRetestFailover :: DiffTime + , appUserdbSyncWithin :: Maybe NominalDiffTime + , appUserdbSyncInterval :: NominalDiffTime - , appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime + , appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime , appSynchroniseAvsUsersInterval :: NominalDiffTime - , appLdapReTestFailover :: DiffTime - , appSessionFilesExpire :: NominalDiffTime , appKeepUnreferencedFiles :: NominalDiffTime @@ -604,7 +603,7 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] - appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-databases" .!= [] + appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= [] appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" @@ -669,14 +668,13 @@ instance FromJSON AppSettings where appSessionTimeout <- o .: "session-timeout" - appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within" - appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval" + appUserdbRetestFailover <- o .: "userdb-retest-failover" + appUserdbSyncWithin <- o .:? "userdb-sync-within" + appUserdbSyncInterval <- o .: "userdb-sync-interval" appSynchroniseAvsUsersWithin <- o .:? "synchronise-avs-users-within" appSynchroniseAvsUsersInterval <- o .: "synchronise-avs-users-interval" - appLdapReTestFailover <- o .: "ldap-re-test-failover" - appSessionFilesExpire <- o .: "session-files-expire" appKeepUnreferencedFiles <- o .:? "keep-unreferenced-files" .!= 0 appInjectFiles <- o .:? "inject-files" From 55ed01cb40a9325d9f461563f0bccaa5708a1764 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 19 Jan 2024 23:23:23 +0100 Subject: [PATCH 015/178] chore: improve settings, rename old ldap settings --- config/settings.yml | 43 ++++++++++++++--------------- src/Handler/Admin/Test.hs | 6 ++-- src/Jobs/Crontab.hs | 10 +++---- src/Jobs/Handler/SynchroniseLdap.hs | 4 +-- src/Jobs/HealthReport.hs | 4 +-- src/Settings/OAuth2.hs | 14 ++++++---- 6 files changed, 41 insertions(+), 40 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index dd2e31924..d2833483b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -24,9 +24,9 @@ mail-from: email: "_env:MAILFROM_EMAIL:uniworx@localhost" mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true" -mail-reroute-to: - name: "_env:MAIL_REROUTE_TO_NAME:" - email: "_env:MAIL_REROUTE_TO_EMAIL:" +mail-reroute-to: + name: "_env:MAIL_REROUTE_TO_NAME:" + email: "_env:MAIL_REROUTE_TO_EMAIL:" #mail-verp: # separator: "_env:VERP_SEPARATOR:+" # prefix: "_env:VERP_PREFIX:bounce" @@ -45,7 +45,7 @@ legal-external: imprint: "https://www.fraport.com/de/tools/impressum.html" data-protection: "https://www.fraport.com/de/konzern/datenschutz.html" terms-of-use: "https://www.fraport.com/de/tools/disclaimer.html" - payments: "https://www.fraport.com/de/geschaeftsfelder/service/geschaeftspartner/richtlinien-und-zahlungsbedingungen.html" + payments: "https://www.fraport.com/de/geschaeftsfelder/service/geschaeftspartner/richtlinien-und-zahlungsbedingungen.html" job-workers: "_env:JOB_WORKERS:10" job-flush-interval: "_env:JOB_FLUSH:30" @@ -133,28 +133,27 @@ auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' user-database: - protocol: "oauth2" config: - client-id: "_env:OAUTH2CLIENTID:" - client-secret: "_env:OAUTH2CLIENTSECRET:" - tenant-id: "_env:OAUTH2TENANTID:" - scopes: "_env:OAUTH2SCOPES:[]" + client-id: "_env:OAUTH2CLIENTID:" + client-secret: "_env:OAUTH2CLIENTSECRET:" + tenant-id: "_env:OAUTH2TENANTID:" - protocol: "ldap" config: - host: "_env:LDAPHOST:" - tls: "_env:LDAPTLS:" - port: "_env:LDAPPORT:389" - user: "_env:LDAPUSER:" - pass: "_env:LDAPPASS:" - baseDN: "_env:LDAPBASE:" - scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" + host: "_env:LDAPHOST:" + tls: "_env:LDAPTLS:" + port: "_env:LDAPPORT:389" + user: "_env:LDAPUSER:" + pass: "_env:LDAPPASS:" + baseDN: "_env:LDAPBASE:" + scope: "_env:LDAPSCOPE:WholeSubtree" + timeout: "_env:LDAPTIMEOUT:5" search-timeout: "_env:LDAPSEARCHTIME:5" pool: - stripes: "_env:LDAPSTRIPES:1" - timeout: "_env:LDAPTIMEOUT:20" - limit: "_env:LDAPLIMIT:10" + stripes: "_env:LDAPSTRIPES:1" + timeout: "_env:LDAPTIMEOUT:20" + limit: "_env:LDAPLIMIT:10" userdb-retest-failover: 60 -userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden +userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600" # jede Stunde @@ -175,7 +174,7 @@ avs: lpr: host: "_env:LPRHOST:fravm017173.fra.fraport.de" port: "_env:LPRPORT:515" - queue: "_env:LPRQUEUE:fradrive" + queue: "_env:LPRQUEUE:fradrive" smtp: host: "_env:SMTPHOST:" @@ -198,7 +197,7 @@ widget-memcached: timeout: "_env:WIDGET_MEMCACHED_TIMEOUT:20" base-url: "_env:WIDGET_MEMCACHED_ROOT:" expiration: "_env:WIDGET_MEMCACHED_EXPIRATION:3600" - + session-memcached: host: "_env:SESSION_MEMCACHED_HOST:localhost" port: "_env:SESSION_MEMCACHED_PORT:11211" diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 1969f8717..d89ca8ea6 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -321,8 +321,8 @@ postAdminTestR = do
appJobCronInterval
#{tshow appJobCronInterval} -
appSynchroniseLdapUsersWithin -
#{tshow appSynchroniseLdapUsersWithin} +
appUserDbSyncWithin +
#{tshow appUserdbSyncWithin}
appSynchroniseAvsUsersWithin
#{tshow appSynchroniseAvsUsersWithin} |] diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 05725f0bf..f1f391f19 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -312,10 +312,10 @@ determineCrontab = execWriterT $ do if -- TODO: generalize user sync job to oauth | is _Just appUserDbConf - , Just syncWithin <- appSynchroniseLdapUsersWithin + , Just syncWithin <- appUserdbSyncWithin , Just cInterval <- appJobCronInterval -> do - nextIntervals <- getNextIntervals syncWithin appSynchroniseLdapUsersInterval cInterval + nextIntervals <- getNextIntervals syncWithin appUserdbSyncInterval cInterval forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do tell $ HashMap.singleton @@ -327,8 +327,8 @@ determineCrontab = execWriterT $ do Cron { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ toTimeOfDay 23 30 0 $ utctDay nextIntervalTime , cronRepeat = CronRepeatNever - , cronRateLimit = appSynchroniseLdapUsersInterval - , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appSynchroniseLdapUsersInterval nextIntervalTime + , cronRateLimit = appUserdbSyncInterval + , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appUserdbSyncInterval nextIntervalTime } | otherwise -> return () diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 52572d879..1a83dc555 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -52,7 +52,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey $logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|] - reTestAfter <- getsYesod $ view _appLdapReTestFailover + reTestAfter <- getsYesod $ view _appUserdbRetestFailover ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user void . lift $ upsertCampusUser (UpsertCampusUserLdapSync upsertIdent) ldapAttrs Nothing -> diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 1f503321b..68ada28f3 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -110,7 +110,7 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _ dispatchHealthCheckLDAPAdmins :: Handler HealthReport dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do ldapPool' <- getsYesod appLdapPool - reTestAfter <- getsYesod $ view _appLdapReTestFailover + reTestAfter <- getsYesod $ view _appUserdbRetestFailover case ldapPool' of Just ldapPool -> do ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs index 98e1908b4..c1c5fbeba 100644 --- a/src/Settings/OAuth2.hs +++ b/src/Settings/OAuth2.hs @@ -10,11 +10,9 @@ module Settings.OAuth2 import ClassyPrelude import Utils.Lens.TH -import Utils.PathPiece (camelToPathPiece) import Data.Aeson -import Data.Aeson.TH - +import qualified Data.Set as Set -- TODO: use better types @@ -27,6 +25,10 @@ data OAuth2Conf = OAuth2Conf makeLenses_ ''OAuth2Conf -deriveFromJSON defaultOptions - { fieldLabelModifier = camelToPathPiece . dropPrefix "oauth2" - } ''OAuth2Conf +instance FromJSON OAuth2Conf where + parseJSON = withObject "OAuth2Conf" $ \o -> do + oauth2ClientId <- o .:? "client-id" .!= "" + oauth2ClientSecret <- o .:? "client-secret" .!= "" + oauth2TenantId <- o .:? "tenant-id" .!= "" + oauth2Scopes <- o .:? "scopes" .!= Set.empty + return OAuth2Conf{..} From 1f31fe8cf2c160f9a82c765ae9f93f62e44d1868 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 23 Jan 2024 02:16:06 +0100 Subject: [PATCH 016/178] chore(settings): add support for multiple modes for userdb --- config/settings.yml | 35 +++++++++++++++++---------------- src/Jobs/Crontab.hs | 5 ++--- src/Settings.hs | 48 ++++++++++++++++++++++++++++++++++----------- 3 files changed, 57 insertions(+), 31 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index d2833483b..0e45357f0 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -131,32 +131,33 @@ auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' # External databases used for authentication and user data lookup # If the first user database in the list is unreachable, the application will perform a failover to the next list entry, etc. user-database: - - protocol: "oauth2" + mode: simple + config: + protocol: "oauth2" config: client-id: "_env:OAUTH2CLIENTID:" client-secret: "_env:OAUTH2CLIENTSECRET:" tenant-id: "_env:OAUTH2TENANTID:" - - protocol: "ldap" - config: - host: "_env:LDAPHOST:" - tls: "_env:LDAPTLS:" - port: "_env:LDAPPORT:389" - user: "_env:LDAPUSER:" - pass: "_env:LDAPPASS:" - baseDN: "_env:LDAPBASE:" - scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" - search-timeout: "_env:LDAPSEARCHTIME:5" - pool: - stripes: "_env:LDAPSTRIPES:1" - timeout: "_env:LDAPTIMEOUT:20" - limit: "_env:LDAPLIMIT:10" + # protocol: "ldap" + # config: + # host: "_env:LDAPHOST:" + # tls: "_env:LDAPTLS:" + # port: "_env:LDAPPORT:389" + # user: "_env:LDAPUSER:" + # pass: "_env:LDAPPASS:" + # baseDN: "_env:LDAPBASE:" + # scope: "_env:LDAPSCOPE:WholeSubtree" + # timeout: "_env:LDAPTIMEOUT:5" + # search-timeout: "_env:LDAPSEARCHTIME:5" + # pool: + # stripes: "_env:LDAPSTRIPES:1" + # timeout: "_env:LDAPTIMEOUT:20" + # limit: "_env:LDAPLIMIT:10" userdb-retest-failover: 60 userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600" # jede Stunde - lms-direct: upload-header: "_env:LMSUPLOADHEADER:true" upload-delimiter: "_env:LMSUPLOADDELIMITER:" diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index f1f391f19..3f38e7724 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -311,9 +311,8 @@ determineCrontab = execWriterT $ do if -- TODO: generalize user sync job to oauth - | is _Just appUserDbConf - , Just syncWithin <- appUserdbSyncWithin - , Just cInterval <- appJobCronInterval + | Just syncWithin <- appUserdbSyncWithin + , Just cInterval <- appJobCronInterval -> do nextIntervals <- getNextIntervals syncWithin appUserdbSyncInterval cInterval diff --git a/src/Settings.hs b/src/Settings.hs index 2d811865c..177ae6611 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -48,7 +48,7 @@ import Data.Word (Word16) import qualified Data.Text as Text -import qualified Ldap.Client as Ldap +-- import qualified Ldap.Client as Ldap import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) import qualified Network.Socket as HaskellNet @@ -79,7 +79,7 @@ import qualified Web.ServerSession.Core as ServerSession import Text.Show (showParen, showString) -import qualified Data.List.PointedList as P +-- import qualified Data.List.PointedList as P import qualified Network.Minio as Minio @@ -142,10 +142,22 @@ instance FromJSON PWHashConf where return PWHashConf{..} -data UserDbConf = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf +data UserDbConf' = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf deriving (Show) -makePrisms ''UserDbConf +data UserDbConf = + UserDbSimple -- ^ use only one specific source + { userdbSource :: UserDbConf' + } + -- TODO: other modes yet to be implemented + -- | UserDbFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable + -- { userdbFailoverSources :: PointedList UserDbConf + -- , userDbFailoverRetest :: NominalDiffTime + -- } + -- | UserDbMerge -- ^ Multiple coequal user sources + -- { userdbMergeSources :: Set UserDbConf + -- } + deriving (Show) data LmsConf = LmsConf { lmsUploadHeader :: Bool @@ -297,10 +309,23 @@ pathPieceJSONKey ''SettingBotMitigation makePrisms ''JobMode makeLenses_ ''JobMode +makePrisms ''UserDbConf' +makeLenses_ ''UserDbConf +makePrisms ''UserDbConf + deriveFromJSON defaultOptions { constructorTagModifier = toLower . dropPrefix "UserDb" , sumEncoding = TaggedObject "protocol" "config" - } ''UserDbConf + } ''UserDbConf' + +instance FromJSON UserDbConf where + parseJSON = withObject "UserDbConf" $ \o -> do + mode <- o .: "mode" + case mode of + "simple" -> do + userdbSource <- o .: "config" + return UserDbSimple{..} + other -> error $ "Unsupported user database mode: " <> other instance FromJSON HaskellNet.PortNumber where parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of @@ -428,7 +453,7 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool - , appUserDbConf :: Maybe (PointedList UserDbConf) + , appUserDbConf :: UserDbConf -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory @@ -599,11 +624,12 @@ instance FromJSON AppSettings where appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" appAutoDbMigrate <- o .: "auto-db-migrate" - let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of - Ldap.Tls host _ -> not $ null host - Ldap.Plain host -> not $ null host - nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] - appUserDbConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= [] + -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of + -- Ldap.Tls host _ -> not $ null host + -- Ldap.Plain host -> not $ null host + -- nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] + appUserDbConf <- o .: "user-database" + -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= [] appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" From 9dc6ec461c3a3ef307d72284ed4050c50c577828 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 23 Jan 2024 02:59:25 +0100 Subject: [PATCH 017/178] chore(settings): simplify/flatten userdb config settings --- config/settings.yml | 11 +++++------ src/Settings.hs | 22 ++++++++++------------ 2 files changed, 15 insertions(+), 18 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 0e45357f0..979297cd7 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -131,13 +131,12 @@ auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' # External databases used for authentication and user data lookup # If the first user database in the list is unreachable, the application will perform a failover to the next list entry, etc. user-database: - mode: simple + mode: single-source + protocol: oauth2 config: - protocol: "oauth2" - config: - client-id: "_env:OAUTH2CLIENTID:" - client-secret: "_env:OAUTH2CLIENTSECRET:" - tenant-id: "_env:OAUTH2TENANTID:" + client-id: "_env:OAUTH2CLIENTID:" + client-secret: "_env:OAUTH2CLIENTSECRET:" + tenant-id: "_env:OAUTH2TENANTID:" # protocol: "ldap" # config: # host: "_env:LDAPHOST:" diff --git a/src/Settings.hs b/src/Settings.hs index 177ae6611..133613cdd 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -146,16 +146,16 @@ data UserDbConf' = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf deriving (Show) data UserDbConf = - UserDbSimple -- ^ use only one specific source - { userdbSource :: UserDbConf' + UserDbSingleSource -- ^ use only one specific source + { userdbSingleSource :: UserDbConf' } -- TODO: other modes yet to be implemented -- | UserDbFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable -- { userdbFailoverSources :: PointedList UserDbConf -- , userDbFailoverRetest :: NominalDiffTime -- } - -- | UserDbMerge -- ^ Multiple coequal user sources - -- { userdbMergeSources :: Set UserDbConf + -- | UserDbMultiSource -- ^ Multiple coequal user sources + -- { userdbMultiSources :: Set UserDbConf -- } deriving (Show) @@ -318,14 +318,12 @@ deriveFromJSON defaultOptions , sumEncoding = TaggedObject "protocol" "config" } ''UserDbConf' -instance FromJSON UserDbConf where - parseJSON = withObject "UserDbConf" $ \o -> do - mode <- o .: "mode" - case mode of - "simple" -> do - userdbSource <- o .: "config" - return UserDbSimple{..} - other -> error $ "Unsupported user database mode: " <> other +deriveFromJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "mode" "config" + , unwrapUnaryRecords = True + } ''UserDbConf instance FromJSON HaskellNet.PortNumber where parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of From 74f044919ce70214669fd471bbb293e0dd0605a6 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:21:33 +0100 Subject: [PATCH 018/178] chore(model): add azure primary key --- models/users.model | 3 +++ 1 file changed, 3 insertions(+) diff --git a/models/users.model b/models/users.model index b23fe85b2..fa4bdfce5 100644 --- a/models/users.model +++ b/models/users.model @@ -21,7 +21,9 @@ User json -- Each Uni2work user has a corresponding row in this table; create lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() lastLdapSynchronisation UTCTime Maybe + lastAzureSynchronisation UTCTime Maybe ldapPrimaryKey UserEduPersonPrincipalName Maybe + azurePrimaryKey UUID Maybe tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer! firstName Text -- For export in tables, pre-split firstName from displayName @@ -53,6 +55,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table UniqueLdapPrimaryKey ldapPrimaryKey !force -- Column 'ldapPrimaryKey' is either empty or contains a unique value + UniqueAzurePrimaryKey azurePrimaryKey !force -- Column 'azurePrimaryKey' is either empty or contains a unique value deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...) From 71af64dc28404bd6b1e5fd639f7f569aad0b2cb1 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:22:58 +0100 Subject: [PATCH 019/178] chore(model): add AuthAzure --- messages/uniworx/categories/user/de-de-formal.msg | 7 ++++--- messages/uniworx/categories/user/en-eu.msg | 7 ++++--- src/Model/Types/Security.hs | 1 + 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a3c630c46..128bf1cdf 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Steffen Jost , Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -38,8 +38,8 @@ AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennun UsersCourseSchool: Bereich ActionNoUsersSelected: Keine Benutzer:innen ausgewählt SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen -SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen -SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen +SynchroniseUserdbUserQueued n@Int: Benutzerdatenbank-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen +SynchroniseUserdbAllUsersQueued: Benutzerdatenbank-Synchronisation von allen Benutzer:innen angestoßen UserListTitle: Komprehensive Benutzerliste AccessRightsSaved: Berechtigungen erfolgreich verändert AccessRightsNotChanged: Berechtigungen wurden nicht verändert @@ -48,6 +48,7 @@ AuthLDAPInvalidLookup: Bestehender Nutzer/Bestehende Nutzerin konnte nicht einde AuthLDAPAlreadyConfigured: Nutzer:in meldet sich bereits per Fraport AG Kennung in FRADrive an AuthLDAPConfigured: Nutzer:in meldet sich nun per Fraport AG Kennung in FRADrive an AuthLDAP !ident-ok: Fraport AG Kennung +AuthAzure: Azure-Account AuthNoLogin: Kein Login erlaubt. PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt UserAssimilateUser: Benutzer:in diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 10c42830d..a603bfe23 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost , Steffen Jost , Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -38,8 +38,8 @@ AuthPWHashConfigured: User now logs in using their FRADrive specific account UsersCourseSchool: Department ActionNoUsersSelected: No users selected SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}. -SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}. -SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users +SynchroniseUserdbUserQueued n: Triggered user database synchronisation of #{n} #{pluralEN n "user" "users"}. +SynchroniseUserdbAllUsersQueued: Triggered user database synchronisation of all users UserListTitle: Comprehensive list of users AccessRightsSaved: Successfully updated permissions AccessRightsNotChanged: Permissions left unchanged @@ -48,6 +48,7 @@ AuthLDAPInvalidLookup: Existing user could not be uniquely matched with a LDAP e AuthLDAPAlreadyConfigured: User already logs in using their Fraport AG account AuthLDAPConfigured: User now logs in using their Fraport AG account AuthLDAP: Fraport AG account +AuthAzure: Azure account AuthNoLogin: No login allowed. PasswordResetQueued: Sent link to reset password UserAssimilateUser: User diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index cb73195b2..e9ba741ae 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -55,6 +55,7 @@ import Data.Binary.Instances.UnorderedContainers () data AuthenticationMode = AuthLDAP + | AuthAzure | AuthPWHash { authPWHash :: Text } | AuthNoLogin deriving (Eq, Ord, Read, Show, Generic) From 4051d1e11b758d55a00ba2ce7dee68ae59a6b213 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:24:40 +0100 Subject: [PATCH 020/178] chore(settings): refactor userdb config structure --- config/settings.yml | 23 ++++++++++++----------- src/Settings.hs | 9 ++++++--- src/Settings/Ldap.hs | 5 +---- src/Settings/OAuth2.hs | 34 ++++++++++++++++------------------ 4 files changed, 35 insertions(+), 36 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 979297cd7..4de2d872a 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -128,15 +128,15 @@ database: auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' -# External databases used for authentication and user data lookup -# If the first user database in the list is unreachable, the application will perform a failover to the next list entry, etc. +# External databases used for authentication and userdata lookups user-database: mode: single-source - protocol: oauth2 + protocol: azureadv2 config: - client-id: "_env:OAUTH2CLIENTID:" - client-secret: "_env:OAUTH2CLIENTSECRET:" - tenant-id: "_env:OAUTH2TENANTID:" + client-id: "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000" + client-secret: "_env:AZURECLIENTSECRET:verysecret" + tenant-id: "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000" + scopes: "_env:AZURESCOPES:[]" # protocol: "ldap" # config: # host: "_env:LDAPHOST:" @@ -148,12 +148,13 @@ user-database: # scope: "_env:LDAPSCOPE:WholeSubtree" # timeout: "_env:LDAPTIMEOUT:5" # search-timeout: "_env:LDAPSEARCHTIME:5" - # pool: - # stripes: "_env:LDAPSTRIPES:1" - # timeout: "_env:LDAPTIMEOUT:20" - # limit: "_env:LDAPLIMIT:10" -userdb-retest-failover: 60 +ldap-pool: + stripes: "_env:LDAPSTRIPES:1" + timeout: "_env:LDAPTIMEOUT:20" + limit: "_env:LDAPLIMIT:10" + +# userdb-retest-failover: 60 userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600" # jede Stunde diff --git a/src/Settings.hs b/src/Settings.hs index 133613cdd..d86518124 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -142,7 +142,7 @@ instance FromJSON PWHashConf where return PWHashConf{..} -data UserDbConf' = UserDbLdap LdapConf | UserDbOAuth2 OAuth2Conf +data UserDbConf' = UserDbLdap LdapConf | UserDbAzureAdV2 AzureConf deriving (Show) data UserDbConf = @@ -517,10 +517,12 @@ data AppSettings = AppSettings , appHealthCheckHTTPReachableTimeout :: NominalDiffTime , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime - , appUserdbRetestFailover :: DiffTime + -- , appUserdbRetestFailover :: DiffTime , appUserdbSyncWithin :: Maybe NominalDiffTime , appUserdbSyncInterval :: NominalDiffTime + , appLdapPoolConf :: Maybe ResourcePoolConf + , appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime , appSynchroniseAvsUsersInterval :: NominalDiffTime @@ -628,6 +630,7 @@ instance FromJSON AppSettings where -- nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] appUserDbConf <- o .: "user-database" -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= [] + appLdapPoolConf <- o .:? "ldap-pool" appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" @@ -692,7 +695,7 @@ instance FromJSON AppSettings where appSessionTimeout <- o .: "session-timeout" - appUserdbRetestFailover <- o .: "userdb-retest-failover" + -- appUserdbRetestFailover <- o .: "userdb-retest-failover" appUserdbSyncWithin <- o .:? "userdb-sync-within" appUserdbSyncInterval <- o .: "userdb-sync-interval" diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs index 0a3bdea23..88df04e9d 100644 --- a/src/Settings/Ldap.hs +++ b/src/Settings/Ldap.hs @@ -6,12 +6,11 @@ module Settings.Ldap ( LdapConf(..) - , _ldapHost, _ldapDn, _ldapBase, _ldapScope, _ldapTimeout, _ldapSearchTimeout, _ldapPool + , _ldapHost, _ldapDn, _ldapBase, _ldapScope, _ldapTimeout, _ldapSearchTimeout ) where import ClassyPrelude -import Settings.ResourcePool import Utils.Lens.TH import Control.Monad.Fail (fail) @@ -33,7 +32,6 @@ data LdapConf = LdapConf , ldapScope :: Ldap.Scope , ldapTimeout :: NominalDiffTime , ldapSearchTimeout :: Int32 - , ldapPool :: ResourcePoolConf } deriving (Show) makeLenses_ ''LdapConf @@ -60,5 +58,4 @@ instance FromJSON LdapConf where ldapScope <- o .: "scope" ldapTimeout <- o .: "timeout" ldapSearchTimeout <- o .: "search-timeout" - ldapPool <- o .: "pool" return LdapConf{..} diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs index c1c5fbeba..a07bc606f 100644 --- a/src/Settings/OAuth2.hs +++ b/src/Settings/OAuth2.hs @@ -3,32 +3,30 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later module Settings.OAuth2 - ( OAuth2Conf(..) - , _oauth2ClientId, _oauth2ClientSecret, _oauth2TenantId, _oauth2Scopes + ( AzureConf(..) + , _azureClientId, _azureClientSecret, _azureTenantId, _azureScopes ) where import ClassyPrelude -import Utils.Lens.TH - import Data.Aeson -import qualified Data.Set as Set +import Data.Aeson.TH +import Data.UUID + +import Utils.Lens.TH +import Utils.PathPiece (camelToPathPiece') -- TODO: use better types -data OAuth2Conf = OAuth2Conf - { oauth2ClientId :: Text - , oauth2ClientSecret :: Text - , oauth2TenantId :: Text - , oauth2Scopes :: Set Text +data AzureConf = AzureConf + { azureClientId :: UUID + , azureClientSecret :: Text + , azureTenantId :: UUID + , azureScopes :: Set Text -- TODO: use better type } deriving (Show) -makeLenses_ ''OAuth2Conf +makeLenses_ ''AzureConf -instance FromJSON OAuth2Conf where - parseJSON = withObject "OAuth2Conf" $ \o -> do - oauth2ClientId <- o .:? "client-id" .!= "" - oauth2ClientSecret <- o .:? "client-secret" .!= "" - oauth2TenantId <- o .:? "tenant-id" .!= "" - oauth2Scopes <- o .:? "scopes" .!= Set.empty - return OAuth2Conf{..} +deriveFromJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''AzureConf From c929d42ebdb8b8ef810bde44ae52c6ddfd91196c Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:26:00 +0100 Subject: [PATCH 021/178] chore(foundation): rename auth exceptions --- src/Foundation/Types.hs | 41 +++++++++++++---------------------------- 1 file changed, 13 insertions(+), 28 deletions(-) diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index 252c1be26..96e858dfe 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -1,39 +1,24 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,David Mosbach +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Gregor Kleen , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Foundation.Types - ( UpsertCampusUserMode(..) - , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser - , _upsertCampusUserIdent - , UpsertAzureUserMode(..) - , _UpsertAzureUserLoginOAuth, _UpsertAzureUserLoginDummy, _UpsertAzureUserLoginOther, _UpsertAzureUserOAuthSync, _UpsertAzureUserGuessUser - , _upsertAzureUserIdent + ( UpsertUserMode(..) + , _UpsertUserLoginLdap, _UpsertUserLoginAzure, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser + , _upsertUserIdent ) where import Import.NoFoundation -data UpsertCampusUserMode - = UpsertCampusUserLoginLdap - | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent } - | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login - | UpsertCampusUserLdapSync { upsertCampusUserIdent :: UserIdent } - | UpsertCampusUserGuessUser +data UpsertUserMode + = UpsertUserLoginLdap + | UpsertUserLoginAzure + | UpsertUserLoginDummy { upsertUserIdent :: UserIdent } + | UpsertUserLoginOther { upsertUserIdent :: UserIdent } -- does not allow further login + | UpsertUserSync { upsertUserIdent :: UserIdent } + | UpsertUserGuessUser deriving (Eq, Ord, Read, Show, Generic) -makeLenses_ ''UpsertCampusUserMode -makePrisms ''UpsertCampusUserMode - - --- Azure users logging in via OAuth2 -data UpsertAzureUserMode - = UpsertAzureUserLoginOAuth - | UpsertAzureUserLoginDummy { upsertAzureUserIdent :: UserIdent } - | UpsertAzureUserLoginOther { upsertAzureUserIdent :: UserIdent } - | UpsertAzureUserOAuthSync { upsertAzureUserIdent :: UserIdent } - | UpsertAzureUserGuessUser - deriving (Eq, Ord, Read, Show, Generic) - -makeLenses_ ''UpsertAzureUserMode -makePrisms ''UpsertAzureUserMode +makeLenses_ ''UpsertUserMode +makePrisms ''UpsertUserMode From a42ccb0faa85d9946f0c4e4bbf8f951dccd3bea5 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:26:53 +0100 Subject: [PATCH 022/178] chore(auth): campus->ldap --- src/Auth/LDAP.hs | 162 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 116 insertions(+), 46 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 329bb0a29..f3e690e85 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,9 +9,9 @@ module Auth.LDAP , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) - , campusUser, campusUser', campusUser'' - , campusUserReTest, campusUserReTest' - , campusUserMatr, campusUserMatr' + , ldapUser, ldapUser', ldapUser'' + , ldapUserReTest, ldapUserReTest' + , ldapUserMatr, ldapUserMatr' , CampusMessage(..) , ldapPrimaryKey , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName @@ -24,20 +24,25 @@ module Auth.LDAP import Import.NoFoundation -import qualified Data.CaseInsensitive as CI - -import Utils.Metrics -import Utils.Form +import Auth.LDAP.AD import qualified Ldap.Client as Ldap +import Utils.Form +import Utils.Metrics + +import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as Text import qualified Yesod.Auth.Message as Msg -import Auth.LDAP.AD --- allow Ldap.Attr usage as key for Data.Map +-- | Plugin name of the LDAP yesod auth plugin +apLdap :: Text +apLdap = "LDAP" + + +-- | Allow Ldap.Attr usage as key for Data.Map deriving newtype instance Ord Ldap.Attr @@ -53,7 +58,11 @@ data CampusMessage = MsgCampusIdentPlaceholder deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] +findUser :: LdapConf + -> Ldap + -> Text -- ^ needle + -> [Ldap.Attr] + -> IO [Ldap.SearchEntry] findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters where userFilters = @@ -69,14 +78,19 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident ] -findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] +findUserMatr :: LdapConf + -> Ldap + -> Text -- ^ matriculation needle + -> [Ldap.Attr] + -> IO [Ldap.SearchEntry] findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters where userFilters = [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr ] -userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search +userSearchSettings :: LdapConf + -> Ldap.Mod Ldap.Search userSearchSettings LdapConf{..} = mconcat [ Ldap.scope ldapScope , Ldap.size 2 @@ -104,6 +118,7 @@ ldapUserEmail = Ldap.Attr "mail" :| ] +-- TODO: rename data CampusUserException = CampusUserLdapError LdapPoolError | CampusUserNoResult | CampusUserAmbiguous @@ -113,20 +128,21 @@ instance Exception CampusUserException makePrisms ''CampusUserException -campusUserWith :: ( MonadUnliftIO m - , MonadCatch m - ) - => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap + +ldapUserWith :: ( MonadUnliftIO m + , MonadCatch m + ) + => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap -> Failover (LdapConf, LdapPool) -> FailoverMode -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) - ) - -> Failover (LdapConf, LdapPool) - -> FailoverMode - -> Creds site - -> m (Either CampusUserException (Ldap.AttrList [])) -campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do + ) + -> Failover (LdapConf, LdapPool) + -> FailoverMode + -> Creds site + -> m (Either CampusUserException (Ldap.AttrList [])) +ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do lift $ Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do @@ -139,28 +155,74 @@ campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapEr [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwE CampusUserAmbiguous -campusUserReTest :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) -campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds -campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) -campusUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap upsertIdent []) +ldapUserReTest :: ( MonadUnliftIO m + , MonadMask m + , MonadLogger m + ) + => Failover (LdapConf, LdapPool) + -> (Nano -> Bool) + -> FailoverMode + -> Creds site + -> m (Ldap.AttrList []) +ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds + +ldapUserReTest' :: ( MonadMask m + , MonadLogger m + , MonadUnliftIO m + ) + => Failover (LdapConf, LdapPool) + -> (Nano -> Bool) + -> FailoverMode + -> User + -> m (Maybe (Ldap.AttrList [])) +ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent []) where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey -campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) -campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds +ldapUser :: ( MonadMask m + , MonadUnliftIO m + , MonadLogger m + ) + => Failover (LdapConf, LdapPool) + -> FailoverMode + -> Creds site + -> m (Ldap.AttrList []) +ldapUser pool mode creds = throwLeft =<< ldapUserWith withLdapFailover pool mode creds -campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) -campusUser' pool mode User{userIdent} - = campusUser'' pool mode $ CI.original userIdent +ldapUser' :: ( MonadMask m + , MonadUnliftIO m + , MonadLogger m + ) + => Failover (LdapConf, LdapPool) + -> FailoverMode + -> User + -> m (Maybe (Ldap.AttrList [])) +ldapUser' pool mode User{userIdent} + = ldapUser'' pool mode $ CI.original userIdent -campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList [])) -campusUser'' pool mode ident - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident []) +ldapUser'' :: ( MonadMask m + , MonadUnliftIO m + , MonadLogger m + ) + => Failover (LdapConf, LdapPool) + -> FailoverMode + -> Text + -> m (Maybe (Ldap.AttrList [])) +ldapUser'' pool mode ident + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool mode (Creds apLdap ident []) -campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList []) -campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do + +ldapUserMatr :: ( MonadUnliftIO m + , MonadMask m + , MonadLogger m + ) + => Failover (LdapConf, LdapPool) + -> FailoverMode + -> UserMatriculation + -> m (Ldap.AttrList []) +ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword results <- findUserMatr conf ldap userMatr [] case results of @@ -168,10 +230,16 @@ campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwM CampusUserAmbiguous -campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList [])) -campusUserMatr' pool mode - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode - +ldapUserMatr' :: ( MonadMask m + , MonadUnliftIO m + , MonadLogger m + ) + => Failover (LdapConf, LdapPool) + -> FailoverMode + -> UserMatriculation + -> m (Maybe (Ldap.AttrList [])) +ldapUserMatr' pool mode + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool mode newtype ADInvalidCredentials = ADInvalidCredentials ADError @@ -186,15 +254,14 @@ campusForm :: ( RenderMessage (HandlerSite m) FormMessage , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) , RenderMessage (HandlerSite m) CampusMessage , MonadHandler m - ) => WForm m (FormResult CampusLogin) + ) + => WForm m (FormResult CampusLogin) campusForm = do MsgRenderer mr <- getMsgRenderer aFormToWForm $ CampusLogin <$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing -apLdap :: Text -apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth site @@ -203,7 +270,10 @@ campusLogin :: forall site. , RenderMessage site (ValueRequired site) , RenderMessage site ADInvalidCredentials , Button site ButtonSubmit - ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site + ) + => Failover (LdapConf, LdapPool) + -> FailoverMode + -> AuthPlugin site campusLogin pool mode = AuthPlugin{..} where apName :: Text From 843ac60aae5a3aeb20c9a30f053ed6d3d7c77c1e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:27:13 +0100 Subject: [PATCH 023/178] chore(auth): oauth2->azure --- src/Auth/OAuth2.hs | 49 ++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 41 insertions(+), 8 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 9b4efdd5d..a810d43e6 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -1,14 +1,17 @@ --- SPDX-FileCopyrightText: 2023 David Mosbach +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} module Auth.OAuth2 -( AzureUserException(..) -, oauth2MockServer -, mockPluginName -) where + ( apAzure + , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage + , oauth2User + , AzureUserException(..) + , oauth2MockServer + , mockPluginName + ) where import Data.Text @@ -17,14 +20,46 @@ import Import.NoFoundation import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2.Prelude +-- | Plugin name of the OAuth2 yesod plugin for Azure ADv2 +apAzure :: Text +apAzure = "AzureADv2" + data AzureUserException = AzureUserError | AzureUserNoResult - | AzureUserAmbiguous -- TODO + | AzureUserAmbiguous deriving (Show, Eq, Generic) instance Exception AzureUserException + +azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage :: Text +azurePrimaryKey = "id" +azureUserPrincipalName = "userPrincipalName" +azureUserDisplayName = "displayName" +azureUserGivenName = "givenName" +azureUserSurname = "surname" +azureUserMail = "mail" +azureUserTelephone = "businessPhones" +azureUserMobile = "mobilePhone" +azureUserPreferredLanguage = "preferredLanguage" + + +-- | User lookup in an OAuth2 database with given credentials +oauth2User :: ( MonadUnliftIO m + -- , MonadThrow m + ) + => AzureConf + -> Creds site + -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])]) +oauth2User _conf _creds = fmap throwLeft . liftIO . runExceptT $ do + results <- return [] -- TODO + case results of + [] -> throwE AzureUserNoResult + [res] -> return res + _multiple -> throwE AzureUserAmbiguous + + ---------------------------------------- ---- OAuth2 development auth plugin ---- ---------------------------------------- @@ -55,5 +90,3 @@ oauth2MockServer = , credsIdent = userID , credsExtra = setExtra token userResponse } - - From 2e005a90f2bdb843be1ccfea7c00347cee851a48 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:27:52 +0100 Subject: [PATCH 024/178] chore(foundation): remove failover from ldap pool conf --- src/Foundation/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 7fe72bac3..c7cfd977b 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -79,7 +79,7 @@ data UniWorX = UniWorX , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appConnPool :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool - , appLdapPool :: Maybe (Failover (LdapConf, LdapPool)) + , appLdapPool :: Maybe (LdapConf, LdapPool) -- TODO: reintroduce Failover , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool , appHttpManager :: Manager , appLogger :: (ReleaseKey, TVar Logger) From 12bb8b71450e5692f1f5d86a515ca27f1a028af7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:29:50 +0100 Subject: [PATCH 025/178] chore(foundation): loosen tight ldap<>failover coupling, move campusUser to ldapUser --- src/Foundation/Yesod/Auth.hs | 424 ++++++++++++++++++++--------------- 1 file changed, 241 insertions(+), 183 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 2bd046479..47e210866 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,13 +1,12 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Steffen Jost ,David Mosbach +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Steffen Jost , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Foundation.Yesod.Auth ( authenticate - , oAuthenticate - , ldapLookupAndUpsert - , upsertCampusUser - , decodeUserTest + -- , ldapLookupAndUpsert + , upsertLdapUser, upsertAzureUser + , decodeLdapUserTest, decodeAzureUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage ) where @@ -37,19 +36,8 @@ import qualified Data.Text.Encoding as Text import qualified Data.ByteString as ByteString import qualified Data.Set as Set import qualified Data.Map as Map --- import qualified Data.Conduit.Combinators as C - --- import qualified Data.List as List ((\\)) - --- import qualified Data.UUID as UUID --- import Data.ByteArray (convert) --- import Crypto.Hash (SHAKE128) --- import qualified Data.Binary as Binary - --- import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.Utils as E - --- import Crypto.Hash.Conduit (sinkHash) +import qualified Data.List.PointedList as PointedList +import qualified Data.UUID as UUID authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX @@ -58,15 +46,16 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX ) => Creds UniWorX -> m (AuthenticationResult UniWorX) authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do - $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only + now <- liftIO getCurrentTime let uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertCampusUserMode + upsertMode = creds ^? _upsertUserMode - isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode + isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode + isOther = is (_Just . _UpsertUserLoginOther) upsertMode excRecovery res | isDummy || isOther @@ -82,17 +71,17 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend excHandlers = [ C.Handler $ \case CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + $logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + $logWarnS "Auth" $ "Multiple auth results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do - $logErrorS "LDAP" $ tshow err + $logErrorS "Auth" $ tshow err mr <- getMessageRender excRecovery . ServerError $ mr MsgInternalLdapError , C.Handler $ \(cExc :: CampusUserConversionException) -> do - $logErrorS "LDAP" $ tshow cExc + $logErrorS "Auth" $ tshow cExc mr <- getMessageRender excRecovery . ServerError $ mr cExc ] @@ -110,92 +99,27 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - ldapPool' <- getsYesod $ view _appLdapPool + $logDebugS "auth" $ tshow Creds{..} - flip catches excHandlers $ case ldapPool' of - Just ldapPool + userdbConf <- getsYesod $ view _appUserDbConf + flip catches excHandlers $ case userdbConf of + UserDbSingleSource (UserDbAzureAdV2 azureConf) | Just upsertMode' <- upsertMode -> do - ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} - $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData + azureData <- oauth2User azureConf Creds{..} + $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData + Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData + UserDbSingleSource (UserDbLdap _) + | Just upsertMode' <- upsertMode -> do + -- TODO WIP + ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool + ldapConf <- mkFailover $ PointedList.singleton ldapPool + ldapData <- ldapUser ldapConf FailoverNone Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..} + $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData + Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData _other -> acceptExisting --- | Authentication via AzureADv2 / OAuth 2 -oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX - , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - , YesodAuth UniWorX, UserId ~ AuthId UniWorX - ) - => Creds UniWorX -> m (AuthenticationResult UniWorX) -oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do - $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" - now <- liftIO getCurrentTime - - let - uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertAzureUserMode - - isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server - isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode - - excRecovery res - | isDummy || isOther - = do - case res of - UserError err -> addMessageI Error err - ServerError err -> addMessage Error $ toHtml err - _other -> return () - acceptExisting - | otherwise - = return res - - excHandlers = - [ C.Handler $ \case - AzureUserNoResult -> do - $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent - excRecovery . UserError $ IdentifierNotFound credsIdent - AzureUserAmbiguous -> do - $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent - excRecovery . UserError $ IdentifierNotFound credsIdent - err -> do - $logErrorS "OAuth" $ tshow err - mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from? - , C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not? - $logErrorS "OAuth" $ tshow cExc - mr <- getMessageRender - excRecovery . ServerError $ mr cExc - ] - - acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) - acceptExisting = do - res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - case res of - Authenticated uid - -> associateUserSchoolsByTerms uid - _other - -> return () - case res of - Authenticated uid - | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] - _other -> return res - - $logDebugS "oauth" $ tshow creds - -- TODO If user not in DB then put - pool <- getsYesod $ view _appLdapPool - flip catches excHandlers $ case pool of - Just ldapPool - | Just upsertMode' <- upsertMode -> do - ldapData <- campusUser ldapPool campusUserFailoverMode creds - $logDebugS "OAuth" $ "Successful LDAP lookup of Azure user: " <> tshow ldapData - Authenticated . entityKey <$> upsertAzureUser upsertMode' ldapData - _other - -> acceptExisting - - - data CampusUserConversionException = CampusUserInvalidIdent | CampusUserInvalidEmail @@ -209,19 +133,23 @@ data CampusUserConversionException deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) -_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode -_upsertCampusUserMode mMode cs@Creds{..} - | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent) - | credsPlugin == apLdap = setMode <$> mMode UpsertCampusUserLoginLdap - | otherwise = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent) + +_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode +_upsertUserMode mMode cs@Creds{..} + | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent) + | credsPlugin == apAzure = setMode <$> mMode UpsertUserLoginAzure + | credsPlugin == apLdap = setMode <$> mMode UpsertUserLoginLdap + | otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent) where - setMode UpsertCampusUserLoginLdap + setMode UpsertUserLoginAzure + = cs{ credsPlugin = apAzure } + setMode UpsertUserLoginLdap = cs{ credsPlugin = apLdap } - setMode (UpsertCampusUserLoginDummy ident) + setMode (UpsertUserLoginDummy ident) = cs{ credsPlugin = apDummy , credsIdent = CI.original ident } - setMode (UpsertCampusUserLoginOther ident) + setMode (UpsertUserLoginOther ident) = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) , credsIdent = CI.original ident } @@ -230,73 +158,28 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash -_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode -_upsertAzureUserMode mMode cs@Creds{..} - | credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent) - | credsPlugin == "azureadv2" = setMode <$> mMode UpsertAzureUserLoginOAuth - | otherwise = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent) - where - setMode UpsertAzureUserLoginOAuth - = cs{ credsPlugin = "azureadv2" } - setMode (UpsertAzureUserLoginDummy ident) - = cs{ credsPlugin = mockPluginName - , credsIdent = CI.original ident - } - setMode (UpsertAzureUserLoginOther ident) - = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2") - , credsIdent = CI.original ident - } - setMode _ = cs +-- TODO: rewrite +-- ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) +-- ldapLookupAndUpsert ident = +-- getsYesod (view _appLdapPool) >>= \case +-- Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." +-- Just ldapPool -> +-- campusUser'' ldapPool campusUserFailoverMode ident >>= \case +-- Nothing -> throwM CampusUserNoResult +-- Just ldapResponse -> upsertLdapUser UpsertCampusUserGuessUser ldapResponse - defaultOther = apHash - - - -ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) -ldapLookupAndUpsert ident = - getsYesod (view _appLdapPool) >>= \case - Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." - Just ldapPool -> - campusUser'' ldapPool campusUserFailoverMode ident >>= \case - Nothing -> throwM CampusUserNoResult - Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse - - -upsertAzureUser :: forall m. - ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadCatch m - ) - => UpsertAzureUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -- TODO UpsertAzureUserMode is probably redundant -upsertAzureUser upsertMode = upsertCampusUser (toCampus upsertMode) - where - toCampus :: UpsertAzureUserMode -> UpsertCampusUserMode - toCampus UpsertAzureUserLoginOAuth = UpsertCampusUserLoginLdap - toCampus (UpsertAzureUserLoginDummy u) = UpsertCampusUserLoginDummy u - toCampus (UpsertAzureUserLoginOther u) = UpsertCampusUserLoginOther u - toCampus (UpsertAzureUserOAuthSync u) = UpsertCampusUserLdapSync u - toCampus UpsertAzureUserGuessUser = UpsertCampusUserGuessUser - - -{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP! -upsertCampusUserByCn :: forall m. - ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadThrow m - ) - => Text -> SqlPersistT m (Entity User) -upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])] --} -- | Upsert User DB according to given LDAP data (does not query LDAP itself) -upsertCampusUser :: forall m. +upsertLdapUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadCatch m ) - => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -upsertCampusUser upsertMode ldapData = do + => UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) +upsertLdapUser upsertMode ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults - (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData + (newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] @@ -333,17 +216,72 @@ upsertCampusUser upsertMode ldapData = do return user -decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) +-- | Upsert User DB according to given Azure data (does not query Azure itself) +-- TODO: maybe merge with upsertLdapUser +upsertAzureUser :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode -> [(Text, [ByteString])] -> SqlPersistT m (Entity User) +upsertAzureUser upsertMode azureData = do + now <- liftIO getCurrentTime + userDefaultConf <- getsYesod $ view _appUserDefaults + + (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData + --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? + + oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] [] + + user@(Entity userId userRec) <- case oldUsers of + Just [oldUserId] -> updateGetEntity oldUserId userUpdate + _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate + unless (validDisplayName (newUser ^. _userTitle) + (newUser ^. _userFirstName) + (newUser ^. _userSurname) + (userRec ^. _userDisplayName)) $ + update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] + when (validEmail' (userRec ^. _userEmail)) $ do + let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] + ++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ] + unless (null emUps) $ update userId emUps + -- Attempt to update ident, too: + unless (validEmail' (userRec ^. _userIdent)) $ + void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) + + let + userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' + userSystemFunctions' = do + (_k, v) <- azureData + -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way? + v' <- v + Right str <- return $ Text.decodeUtf8' v' + assertM' (not . Text.null) $ Text.strip str + + iforM_ userSystemFunctions $ \func preset -> do + memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) + if | preset -> void $ upsert (UserSystemFunction userId func False False) [] + | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] + + return user + +decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) -decodeUserTest mbIdent ldapData = do +decodeLdapUserTest mbIdent ldapData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults - let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent - try $ decodeUser now userDefaultConf mode ldapData + let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent + try $ decodeLdapUser now userDefaultConf mode ldapData +decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) + => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (User, [Update User])) +decodeAzureUserTest mbIdent azureData = do + now <- liftIO getCurrentTime + userDefaultConf <- getsYesod $ view _appUserDefaults + let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent + try $ decodeAzureUser now userDefaultConf mode azureData -decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) -decodeUser now UserDefaultConf{..} upsertMode ldapData = do +decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_) +decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do let userTelephone = decodeLdap ldapUserTelephone userMobile = decodeLdap ldapUserMobile @@ -351,11 +289,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userCompanyDepartment = decodeLdap ldapUserFraportAbteilung userAuthentication - | is _UpsertCampusUserLoginOther upsertMode + | is _UpsertUserLoginOther upsertMode = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known") | otherwise = AuthLDAP userLastAuthentication = guardOn isLogin now - isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode + isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName @@ -368,9 +306,9 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userIdent <- if | [bs] <- ldapMap !!! ldapUserPrincipalName , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode + , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode -> return userIdent' - | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent + | Just userIdent' <- upsertMode ^? _upsertUserIdent -> return userIdent' | otherwise -> throwM CampusUserInvalidIdent @@ -412,6 +350,8 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Just now + , userAzurePrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing , userDisplayName = userDisplayName , userDisplayEmail = userEmail , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO @@ -425,7 +365,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do [ UserLastAuthentication =. Just now | isLogin ] ++ [ UserEmail =. userEmail | validEmail' userEmail ] ++ [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName UserFirstName =. userFirstName , UserSurname =. userSurname , UserLastLdapSynchronisation =. Just now @@ -472,6 +412,123 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do -- where -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) +decodeAzureUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_) +decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do + let + userTelephone = decodeAzure azureUserTelephone + userMobile = decodeAzure azureUserMobile + userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer + userCompanyDepartment = Nothing --TODO decodeAzure ldapUserFraportAbteilung + + userAuthentication + | is _UpsertUserLoginOther upsertMode + = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known") + | otherwise = AuthAzure + userLastAuthentication = guardOn isLogin now + isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode + + userTitle = Nothing -- TODO decodeAzure ldapUserTitle -- CampusUserInvalidTitle + userFirstName = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName + userSurname = decodeAzure' azureUserSurname -- CampusUserInvalidSurname + userDisplayName <- decodeAzure1 azureUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName + + --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= + -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname) + + userIdent <- if + | [bs] <- azureMap !!! azureUserPrincipalName + , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs + , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode + -> return userIdent' + | Just userIdent' <- upsertMode ^? _upsertUserIdent + -> return userIdent' + | otherwise + -> throwM CampusUserInvalidIdent + + userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail + -- -> return $ CI.mk userEmail + | otherwise + -> throwM CampusUserInvalidEmail + + -- TODO: use fromASCIIBytes / fromByteString? + userAzurePrimaryKey <- if + | [bs] <- azureMap !!! azurePrimaryKey + , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs + , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey'' + , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey''' + -> return $ Just userAzurePrimaryKey'''' + | otherwise + -> return Nothing + + let + newUser = User + { userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userSex = Nothing + , userBirthday = Nothing + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userLanguages = Nothing -- TODO: decode and parse preferredLanguages + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastAzureSynchronisation = Just now + , userLdapPrimaryKey = Nothing + , userLastLdapSynchronisation = Nothing + , userDisplayName = userDisplayName + , userDisplayEmail = userEmail + , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO + , userPostLastUpdate = Nothing + , userPinPassword = Nothing -- must be derived via AVS + , userPrefersPostal = userDefaultPrefersPostal + , .. + } + userUpdate = + [ UserLastAuthentication =. Just now | isLogin ] ++ + [ UserEmail =. userEmail | validEmail' userEmail ] ++ + [ + -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 + UserFirstName =. userFirstName + , UserSurname =. userSurname + , UserLastAzureSynchronisation =. Just now + , UserAzurePrimaryKey =. userAzurePrimaryKey + , UserMobile =. userMobile + , UserTelephone =. userTelephone + , UserCompanyPersonalNumber =. userCompanyPersonalNumber + , UserCompanyDepartment =. userCompanyDepartment + ] + return (newUser, userUpdate) + + where + azureMap :: Map.Map Text [ByteString] + azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null)) + + -- just returns Nothing on error, pure + decodeAzure :: Text -> Maybe Text + decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr + + decodeAzure' :: Text -> Text + decodeAzure' = fromMaybe "" . decodeAzure + + -- only accepts the first successful decoding, ignoring all others, but failing if there is none + -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text + decodeAzure1 attr err + | (h:_) <- rights vs = return h + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (azureMap !!! attr) + associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms uid = do @@ -486,6 +543,7 @@ associateUserSchoolsByTerms uid = do , userSchoolIsOptOut = False } + updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX , YesodAuth UniWorX , UserId ~ AuthId UniWorX From ff5b31929ef851fa3915297a18c5acf126357e7a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:31:13 +0100 Subject: [PATCH 026/178] refactor(jobs): ldap->userdb --- src/Jobs.hs | 4 +- src/Jobs/Crontab.hs | 3 +- src/Jobs/Handler/SynchroniseLdap.hs | 64 ------------------------- src/Jobs/Handler/SynchroniseUserdb.hs | 68 +++++++++++++++++++++++++++ src/Jobs/Types.hs | 8 ++-- 5 files changed, 75 insertions(+), 72 deletions(-) delete mode 100644 src/Jobs/Handler/SynchroniseLdap.hs create mode 100644 src/Jobs/Handler/SynchroniseUserdb.hs diff --git a/src/Jobs.hs b/src/Jobs.hs index f48922abb..79c17ba25 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -71,7 +71,7 @@ import Jobs.Handler.SendCourseCommunication import Jobs.Handler.Invitation import Jobs.Handler.SendPasswordReset import Jobs.Handler.TransactionLog -import Jobs.Handler.SynchroniseLdap +import Jobs.Handler.SynchroniseUserdb import Jobs.Handler.SynchroniseAvs import Jobs.Handler.PruneInvitations import Jobs.Handler.ChangeUserDisplayEmail @@ -493,7 +493,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker , Exc.Handler $ \case MailNotAvailable -> return $ Right () e -> return . Left $ SomeException e - , Exc.Handler $ \SynchroniseLdapNoLdap -> return $ Right () + , Exc.Handler $ \SynchroniseUserdbNoLdap -> return $ Right () -- TODO #endif , Exc.Handler $ \(e :: SomeException) -> return $ Left e ] . fmap Right diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 3f38e7724..15819e6de 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -310,7 +310,6 @@ determineCrontab = execWriterT $ do return (nextEpoch, nextInterval, nextIntervalTime, numIntervals) if - -- TODO: generalize user sync job to oauth | Just syncWithin <- appUserdbSyncWithin , Just cInterval <- appJobCronInterval -> do @@ -318,7 +317,7 @@ determineCrontab = execWriterT $ do forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do tell $ HashMap.singleton - (JobCtlQueue JobSynchroniseLdap + (JobCtlQueue JobSynchroniseUserdb { jEpoch = fromInteger nextEpoch , jNumIterations = fromInteger numIntervals , jIteration = fromInteger nextInterval diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs deleted file mode 100644 index 1a83dc555..000000000 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ /dev/null @@ -1,64 +0,0 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -module Jobs.Handler.SynchroniseLdap - ( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser - , SynchroniseLdapException(..) - ) where - -import Import - -import qualified Data.CaseInsensitive as CI -import qualified Data.Conduit.List as C - -import Auth.LDAP -import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser) - -import Jobs.Queue - - -data SynchroniseLdapException - = SynchroniseLdapNoLdap - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -instance Exception SynchroniseLdapException - -dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> JobHandler UniWorX -dispatchJobSynchroniseLdap numIterations epoch iteration - = JobHandlerAtomic . runConduit $ - readUsers .| filterIteration .| sinkDBJobs - where - readUsers :: ConduitT () UserId (YesodJobDB UniWorX) () - readUsers = selectKeys [] [] - - filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) () - filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do - let - userIteration, currentIteration :: Integer - userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations - currentIteration = toInteger iteration `mod` toInteger numIterations - $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] - guard $ userIteration == currentIteration - - return $ JobSynchroniseLdapUser userId - -dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX -dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do - UniWorX{..} <- getYesod - case appLdapPool of - Just ldapPool -> - runDB . void . runMaybeT . handleExc $ do - user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser - let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey - $logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|] - - reTestAfter <- getsYesod $ view _appUserdbRetestFailover - ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user - void . lift $ upsertCampusUser (UpsertCampusUserLdapSync upsertIdent) ldapAttrs - Nothing -> - throwM SynchroniseLdapNoLdap - where - handleExc :: MaybeT DB a -> MaybeT DB a - handleExc - = catchMPlus (Proxy @CampusUserException) - . catchMPlus (Proxy @CampusUserConversionException) diff --git a/src/Jobs/Handler/SynchroniseUserdb.hs b/src/Jobs/Handler/SynchroniseUserdb.hs new file mode 100644 index 000000000..954a5edf2 --- /dev/null +++ b/src/Jobs/Handler/SynchroniseUserdb.hs @@ -0,0 +1,68 @@ +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Jobs.Handler.SynchroniseUserdb + ( dispatchJobSynchroniseUserdb, dispatchJobSynchroniseUserdbUser + , SynchroniseUserdbException(..) + ) where + +import Import + +import qualified Data.CaseInsensitive as CI +import qualified Data.Conduit.List as C + +import Auth.LDAP +import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser) + +import Jobs.Queue + + +data SynchroniseUserdbException + = SynchroniseUserdbNoUserdb + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +instance Exception SynchroniseUserdbException + +dispatchJobSynchroniseUserdb :: Natural -> Natural -> Natural -> JobHandler UniWorX +dispatchJobSynchroniseUserdb numIterations epoch iteration + = JobHandlerAtomic . runConduit $ + readUsers .| filterIteration .| sinkDBJobs + where + readUsers :: ConduitT () UserId (YesodJobDB UniWorX) () + readUsers = selectKeys [] [] + + filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) () + filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do + let + userIteration, currentIteration :: Integer + userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations + currentIteration = toInteger iteration `mod` toInteger numIterations + $logDebugS "SynchroniseUserdb" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] + guard $ userIteration == currentIteration + + return $ JobSynchroniseUserdbUser userId + +dispatchJobSynchroniseUserdbUser :: UserId -> JobHandler UniWorX +dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do + UniWorX{..} <- getYesod + case appUserDbConf of + UserDbSingleSource (UserDbLdap ldapConf) -> + runDB . void . runMaybeT . handleExc $ do + user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser + let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey + $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with LDAP|] + -- reTestAfter <- getsYesod $ view _appUserdbRetestFailover + -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user + ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user + void . lift $ upsertLdapUser (UpsertLdapUserLdapSync upsertIdent) ldapAttrs + UserDbSingleSource (UserDbOAuth2 oauth2Conf) -> + runDB . void . runMaybeT . handleExc $ do + user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser + let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey + $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|] + void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) oauth2Conf + where + handleExc :: MaybeT DB a -> MaybeT DB a + handleExc + = catchMPlus (Proxy @CampusUserException) + . catchMPlus (Proxy @CampusUserConversionException) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index dc8e04120..2e8100cd1 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -92,11 +92,11 @@ data Job | JobTruncateTransactionLog | JobPruneInvitations | JobDeleteTransactionLogIPs - | JobSynchroniseLdap { jNumIterations + | JobSynchroniseUserdb { jNumIterations , jEpoch , jIteration :: Natural } - | JobSynchroniseLdapUser { jUser :: UserId } + | JobSynchroniseUserdbUser { jUser :: UserId } | JobSynchroniseAvs { jNumIterations , jEpoch , jIteration :: Natural @@ -348,8 +348,8 @@ jobNoQueueSame = \case JobTruncateTransactionLog{} -> Just JobNoQueueSame JobPruneInvitations{} -> Just JobNoQueueSame JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame - JobSynchroniseLdap{} -> Just JobNoQueueSame - JobSynchroniseLdapUser{} -> Just JobNoQueueSame + JobSynchroniseUserdb{} -> Just JobNoQueueSame + JobSynchroniseUserdbUser{} -> Just JobNoQueueSame JobSynchroniseAvs{} -> Just JobNoQueueSame JobSynchroniseAvsUser{} -> Just JobNoQueueSame JobSynchroniseAvsId{} -> Just JobNoQueueSame From 3eec9ef8df266fa2ef203c1af12c7f4feea79def Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:32:10 +0100 Subject: [PATCH 027/178] refactor(jobs): ldap->userdb messages --- src/Handler/Users.hs | 8 ++++---- src/Handler/Users/Add.hs | 2 +- src/Handler/Utils/Avs.hs | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2af62ef7d..9baf06c62 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -364,8 +364,8 @@ postUsersR = do | Set.null usersSet && isNotSetSupervisor act -> addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do - forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid - addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet + forM_ userSet $ \uid -> queueJob' $ JobSynchroniseUserdbUser uid + addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing @@ -400,8 +400,8 @@ postUsersR = do formResult allUsersRes $ \case AllUsersLdapSync -> do - runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) - addMessageI Success MsgSynchroniseLdapAllUsersQueued + runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUserdbUser . entityKey) + addMessageI Success MsgSynchroniseUserdbAllUsersQueued redirect UsersR let allUsersWgt' = wrapForm allUsersWgt def { formSubmit = FormNoSubmit diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 872431554..60374b803 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -44,7 +44,7 @@ addNewUserNotify aud = do case mbUid of Nothing -> return Nothing Just uid -> runDBJobs $ do - queueDBJob $ JobSynchroniseLdapUser uid + queueDBJob $ JobSynchroniseUserdbUser uid let authKind = audAuth aud when (authKind /= AuthKindNoLogin) $ queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 42275f139..160a3f337 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -79,7 +79,7 @@ instance Exception AvsException Connect AVS query to LDAP queries for automatic synchronisation: - add query to Auth.LDAP.campusUserMatr - add query to Auth.LDAP.campusLogin - - jobs.Handler.dispatchJobSynchroniseLdap + - jobs.Handler.dispatchJobSynchroniseUserdb -} @@ -462,7 +462,7 @@ upsertAvsUserById api = do , audIdent = fakeIdent -- use AvsPersonId instead , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known } - mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe + mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred From 471982d24511657acf4868e54e769bf839dc2b82 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Jan 2024 23:32:45 +0100 Subject: [PATCH 028/178] chore(application): reimplement ldapPool startup --- src/Application.hs | 37 ++++++++++++++++++++++++++++--------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 1f0499da5..8eb2a1151 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -241,12 +241,12 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} + mkFoundation appSettings' appConnPool appSmtpPool appUserDbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") - (error "ldapPool forced in tempFoundation") + (error "userdbPool forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation") (error "sessionStore forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") @@ -298,14 +298,33 @@ makeFoundation appSettings''@AppSettings{..} = do sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool' void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO - -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do - -- let ldapLabel = case ldapHost of - -- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort - -- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort - -- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel - -- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) + -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appUserDbConf $ \conf -> if + -- | UserDbSingleSource{..} <- conf + -- , UserDbLdap LdapConf{..} <- userdbSingleSource + -- , Just ResourcePoolConf{..} <- userdbPoolConf + -- -> do + -- let ldapLabel = case ldapHost of + -- Ldap.Plain str -> pack str <> ":" <> tshow ldapPort + -- Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort + -- $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel + -- (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit + -- | otherwise + -- -> return mempty -- forM_ ldapPool $ registerFailoverMetrics "ldap" + -- TODO: reintroduce failover once UserDbFailover is implemented (see above) + ldapPool <- forOf (traverse . traverse) appLdapPoolConf $ \RessourcePoolConf{..} -> if + | UserDbSingleSource{..} <- appUserDbConf + , UserDbLdap LdapConf{..} <- userdbSingleSource + -> do -- set up a singleton ldap pool with no failover + let ldapLabel = case ldapHost of + Ldap.Plain str -> pack str <> ":" <> tshow ldapPort + Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort + $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel + (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit + | otherwise -- No LDAP pool to be initialized + -> return mempty + -- Perform database migration using our application's logging settings. flip runReaderT tempFoundation $ if @@ -402,7 +421,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' -- TODO: reimplement user db failover - let foundation = mkFoundation appSettings' sqlPool smtpPool Nothing appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + let foundation = mkFoundation appSettings' sqlPool smtpPool userdbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logInfoS "setup" "*** DONE ***" From 7e3e7720555894ac3755c38a36402ecaf2b754f6 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 12:45:44 +0100 Subject: [PATCH 029/178] chore(foundation): use multifunctional authenticate --- src/Foundation/Instances.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 79fefdccf..8ab8d9beb 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -139,9 +139,7 @@ instance YesodAuth UniWorX where setTitleI MsgLoginTitle $(widgetFile "login") - authenticate c@Creds{..} - | credsPlugin `elem` ["azureadv2", "uniworx_dev"] = UniWorX.oAuthenticate c - | otherwise = UniWorX.authenticate c + authenticate = UniWorX.authenticate authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes [ flip campusLogin campusUserFailoverMode <$> appLdapPool From e9bbeffd7edea390c0c8b844f1bb69c7cd99036e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 12:45:59 +0100 Subject: [PATCH 030/178] chore(auth): campusLogin->ldapLogin --- src/Auth/LDAP.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index f3e690e85..b7a03d4a9 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -7,7 +7,7 @@ module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) - , campusLogin + , ldapLogin , CampusUserException(..) , ldapUser, ldapUser', ldapUser'' , ldapUserReTest, ldapUserReTest' @@ -263,18 +263,18 @@ campusForm = do <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing -campusLogin :: forall site. - ( YesodAuth site - , RenderMessage site CampusMessage - , RenderAFormSite site - , RenderMessage site (ValueRequired site) - , RenderMessage site ADInvalidCredentials - , Button site ButtonSubmit - ) - => Failover (LdapConf, LdapPool) - -> FailoverMode - -> AuthPlugin site -campusLogin pool mode = AuthPlugin{..} +ldapLogin :: forall site. + ( YesodAuth site + , RenderMessage site CampusMessage + , RenderAFormSite site + , RenderMessage site (ValueRequired site) + , RenderMessage site ADInvalidCredentials + , Button site ButtonSubmit + ) + => (LdapConf, LdapPool) -- TODO: reintroduce Failover + -> FailoverMode + -> AuthPlugin site +ldapLogin pool mode = AuthPlugin{..} where apName :: Text apName = apLdap @@ -285,7 +285,7 @@ campusLogin pool mode = AuthPlugin{..} tp <- getRouteToParent resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do - ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do + ldapResult <- withLdap _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of From 8acfc1d10c740766b55d5315fa6b413dcad50df5 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 28 Jan 2024 12:53:00 +0000 Subject: [PATCH 031/178] feat(auth): integrated oauth2 mock server --- shell.nix | 30 ++++++++++++++++++++++++++++-- src/Auth/OAuth2.hs | 12 ++++++------ src/Foundation/Instances.hs | 2 +- templates/login.hamlet | 4 ++-- 4 files changed, 37 insertions(+), 11 deletions(-) diff --git a/shell.nix b/shell.nix index 42c65ae1f..329dd7549 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Sarah Vaupel , Steffen Jost +# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , Sarah Vaupel , Steffen Jost , David Mosbach # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,6 +9,12 @@ let haskellPackages = pkgs.haskellPackages; + oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=11548e5aacca29c6ba389a62bca3d7a80d54eb6f&ref=refresh-tokens").packages.x86_64-linux; + + oauth2MockServer = oauth2Flake.default; + mkOauth2DB = oauth2Flake.mkOauth2DB; + killOauth2DB = oauth2Flake.killOauth2DB; + postgresSchema = pkgs.writeText "schema.sql" '' CREATE USER uniworx WITH SUPERUSER; CREATE DATABASE uniworx_test; @@ -21,6 +27,17 @@ let local all all trust ''; + oauth2Schema = pkgs.writeText "oauth2_schema.sql" '' + CREATE USER oauth2mock WITH SUPERUSER; + CREATE DATABASE test_users; + GRANT ALL ON DATABASE test_users TO oauth2mock; + ''; + + oauth2Hba = pkgs.writeText "oauth2_hba_file" '' + local all all trust + ''; + + develop = pkgs.writeScriptBin "develop" '' #!${pkgs.zsh}/bin/zsh -e @@ -44,6 +61,7 @@ let type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached type cleanup_minio &>/dev/null && cleanup_minio type cleanup_maildev &>/dev/null && cleanup_maildev + [[ -z "$OAUTH2_PGDIR" ]] || source ${killOauth2DB}/bin/killOauth2DB [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env" set +x @@ -53,6 +71,12 @@ let export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000)) + if [[ -z "$OAUTH2_PGHOST" ]]; then + set -xe + source ${mkOauth2DB}/bin/mkOauth2DB + set +xe + fi + if [[ -z "$PGHOST" ]]; then set -xe @@ -271,7 +295,9 @@ in pkgs.mkShell { export CHROME_BIN=${pkgs.chromium}/bin/chromium ''; - nativeBuildInputs = [develop inDevelop killallUni2work diffRunning] + OAUTH2_HBA = oauth2Hba; + OAUTH2_DB_SCHEMA = oauth2Schema; + nativeBuildInputs = [develop inDevelop killallUni2work diffRunning oauth2MockServer] ++ (with pkgs; [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client gup reuse pre-commit diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 9b4efdd5d..c3637c0f0 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -30,7 +30,7 @@ instance Exception AzureUserException ---------------------------------------- mockPluginName :: Text -mockPluginName = "uniworx_dev" +mockPluginName = "dev-oauth2-mock" newtype UserID = UserID Text instance FromJSON UserID where @@ -40,14 +40,14 @@ instance FromJSON UserID where oauth2MockServer :: YesodAuth m => AuthPlugin m oauth2MockServer = let oa = OAuth2 - { oauth2ClientId = "uniworx" - , oauth2ClientSecret = Just "shh" - , oauth2AuthorizeEndpoint = fromString $ mockServerURL <> "/authorize" + { oauth2ClientId = "42" + , oauth2ClientSecret = Just "shhh" + , oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth") `withQuery` [scopeParam " " ["ID", "Profile"]] , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token" , oauth2RedirectUri = Nothing } - mockServerURL = "0.0.0.0/" - profileSrc = fromString $ mockServerURL <> "/foo" + mockServerURL = "http://localhost:9443" + profileSrc = fromString $ mockServerURL <> "/users/me" in authOAuth2 mockPluginName oa $ \manager token -> do (UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc return Creds diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 79fefdccf..20d10b2de 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -140,7 +140,7 @@ instance YesodAuth UniWorX where $(widgetFile "login") authenticate c@Creds{..} - | credsPlugin `elem` ["azureadv2", "uniworx_dev"] = UniWorX.oAuthenticate c + | credsPlugin `elem` ["azureadv2", "dev-oauth2-mock"] = UniWorX.oAuthenticate c | otherwise = UniWorX.authenticate c authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes diff --git a/templates/login.hamlet b/templates/login.hamlet index 7c1483d65..bb3ee704e 100644 --- a/templates/login.hamlet +++ b/templates/login.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen +$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,David Mosbach $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,7 +9,7 @@ $forall AuthPlugin{apName, apLogin} <- plugins

Azure ^{apLogin toParent} - $elseif apName == "uniworx_dev" + $elseif apName == "dev-oauth2-mock"

_{MsgDummyLoginTitle} ^{apLogin toParent} From d4a3459adf01201020be97ef6d8f53babc8279d6 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 18:06:30 +0100 Subject: [PATCH 032/178] chore: user sources --- config/settings.yml | 13 +++---- src/Application.hs | 8 ++--- src/Foundation/Yesod/Auth.hs | 10 +++--- src/Jobs/Handler/SynchroniseUserdb.hs | 8 ++--- src/Settings.hs | 50 +++++++++++++-------------- 5 files changed, 45 insertions(+), 44 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 4de2d872a..c7f3018e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -128,9 +128,9 @@ database: auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' -# External databases used for authentication and userdata lookups -user-database: - mode: single-source +# External sources used for authentication and userdata lookups +user-source: +# mode: single-source protocol: azureadv2 config: client-id: "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000" @@ -149,14 +149,15 @@ user-database: # timeout: "_env:LDAPTIMEOUT:5" # search-timeout: "_env:LDAPSEARCHTIME:5" +# TODO: might move later ldap-pool: stripes: "_env:LDAPSTRIPES:1" timeout: "_env:LDAPTIMEOUT:20" limit: "_env:LDAPLIMIT:10" -# userdb-retest-failover: 60 -userdb-sync-within: "_env:USERDB_SYNC_WITHIN:1209600" # 14 Tage in Sekunden -userdb-sync-interval: "_env:USERDB_SYNC_INTERVAL:3600" # jede Stunde +# user-retest-failover: 60 +user-sync-within: "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden +user-sync-interval: "_env:USER_SYNC_INTERVAL:3600" # jede Stunde lms-direct: upload-header: "_env:LMSUPLOADHEADER:true" diff --git a/src/Application.hs b/src/Application.hs index 8eb2a1151..8aa072a36 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -246,7 +246,7 @@ makeFoundation appSettings''@AppSettings{..} = do (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") - (error "userdbPool forced in tempFoundation") + (error "ldapPool forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation") (error "sessionStore forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") @@ -314,8 +314,8 @@ makeFoundation appSettings''@AppSettings{..} = do -- TODO: reintroduce failover once UserDbFailover is implemented (see above) ldapPool <- forOf (traverse . traverse) appLdapPoolConf $ \RessourcePoolConf{..} -> if - | UserDbSingleSource{..} <- appUserDbConf - , UserDbLdap LdapConf{..} <- userdbSingleSource + | UserSourceConfSingleSource{..} <- appUserSourceConf + , UserSourceLdap LdapConf{..} <- usersrcSingleSource -> do -- set up a singleton ldap pool with no failover let ldapLabel = case ldapHost of Ldap.Plain str -> pack str <> ":" <> tshow ldapPort @@ -421,7 +421,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' -- TODO: reimplement user db failover - let foundation = mkFoundation appSettings' sqlPool smtpPool userdbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logInfoS "setup" "*** DONE ***" diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 47e210866..541cf7857 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -101,14 +101,14 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $logDebugS "auth" $ tshow Creds{..} - userdbConf <- getsYesod $ view _appUserDbConf - flip catches excHandlers $ case userdbConf of - UserDbSingleSource (UserDbAzureAdV2 azureConf) + userSourceConf <- getsYesod $ view _appUserSourceConf + flip catches excHandlers $ case userSourceConf of + UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) | Just upsertMode' <- upsertMode -> do - azureData <- oauth2User azureConf Creds{..} + azureData <- azureUser azureConf Creds{..} $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData - UserDbSingleSource (UserDbLdap _) + UserSourceConfSingleSource (UserSourceLdap _) | Just upsertMode' <- upsertMode -> do -- TODO WIP ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool diff --git a/src/Jobs/Handler/SynchroniseUserdb.hs b/src/Jobs/Handler/SynchroniseUserdb.hs index 954a5edf2..34069a90d 100644 --- a/src/Jobs/Handler/SynchroniseUserdb.hs +++ b/src/Jobs/Handler/SynchroniseUserdb.hs @@ -45,8 +45,8 @@ dispatchJobSynchroniseUserdb numIterations epoch iteration dispatchJobSynchroniseUserdbUser :: UserId -> JobHandler UniWorX dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do UniWorX{..} <- getYesod - case appUserDbConf of - UserDbSingleSource (UserDbLdap ldapConf) -> + case appUserSourceConf of + UserSourceConfSingleSource (UserSourceLdap ldapConf) -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey @@ -55,12 +55,12 @@ dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user void . lift $ upsertLdapUser (UpsertLdapUserLdapSync upsertIdent) ldapAttrs - UserDbSingleSource (UserDbOAuth2 oauth2Conf) -> + UserSourceConfSingleSource (UserSourceAzure azureConf) -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|] - void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) oauth2Conf + void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) azureConf where handleExc :: MaybeT DB a -> MaybeT DB a handleExc diff --git a/src/Settings.hs b/src/Settings.hs index d86518124..242b0ca0d 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -142,20 +142,20 @@ instance FromJSON PWHashConf where return PWHashConf{..} -data UserDbConf' = UserDbLdap LdapConf | UserDbAzureAdV2 AzureConf +data UserSource = UserSourceLdap LdapConf | UserSourceAzureAdV2 AzureConf deriving (Show) -data UserDbConf = - UserDbSingleSource -- ^ use only one specific source - { userdbSingleSource :: UserDbConf' +data UserSourceConf = + UserSourceConfSingleSource -- ^ use only one specific source + { usersrcSingleSource :: UserSource } -- TODO: other modes yet to be implemented - -- | UserDbFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable - -- { userdbFailoverSources :: PointedList UserDbConf - -- , userDbFailoverRetest :: NominalDiffTime + -- | UserFailover -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable + -- { usersrcFailoverSources :: PointedList UserSource + -- , usersrcFailoverRetest :: NominalDiffTime -- } - -- | UserDbMultiSource -- ^ Multiple coequal user sources - -- { userdbMultiSources :: Set UserDbConf + -- | UserMultiSource -- ^ Multiple coequal user sources + -- { usersrcMultiSources :: Set UserSource -- } deriving (Show) @@ -309,21 +309,21 @@ pathPieceJSONKey ''SettingBotMitigation makePrisms ''JobMode makeLenses_ ''JobMode -makePrisms ''UserDbConf' -makeLenses_ ''UserDbConf -makePrisms ''UserDbConf +makePrisms ''UserSource +makeLenses_ ''UserSourceConf +makePrisms ''UserSourceConf deriveFromJSON defaultOptions - { constructorTagModifier = toLower . dropPrefix "UserDb" + { constructorTagModifier = toLower . dropPrefix "UserSource" , sumEncoding = TaggedObject "protocol" "config" - } ''UserDbConf' + } ''UserSource deriveFromJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 + { constructorTagModifier = camelToPathPiece' 3 , fieldLabelModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "mode" "config" + , sumEncoding = UntaggedValue -- TaggedObject "mode" "config" , unwrapUnaryRecords = True - } ''UserDbConf + } ''UserSourceConf instance FromJSON HaskellNet.PortNumber where parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of @@ -451,7 +451,7 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool - , appUserDbConf :: UserDbConf + , appUserSourceConf :: UserSourceConf -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory @@ -517,9 +517,9 @@ data AppSettings = AppSettings , appHealthCheckHTTPReachableTimeout :: NominalDiffTime , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime - -- , appUserdbRetestFailover :: DiffTime - , appUserdbSyncWithin :: Maybe NominalDiffTime - , appUserdbSyncInterval :: NominalDiffTime + -- , appUserRetestFailover :: DiffTime + , appUserSyncWithin :: Maybe NominalDiffTime + , appUserSyncInterval :: NominalDiffTime , appLdapPoolConf :: Maybe ResourcePoolConf @@ -628,7 +628,7 @@ instance FromJSON AppSettings where -- Ldap.Tls host _ -> not $ null host -- Ldap.Plain host -> not $ null host -- nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ] - appUserDbConf <- o .: "user-database" + appUserSourceConf <- o .: "user-source" -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= [] appLdapPoolConf <- o .:? "ldap-pool" appLmsConf <- o .: "lms-direct" @@ -695,9 +695,9 @@ instance FromJSON AppSettings where appSessionTimeout <- o .: "session-timeout" - -- appUserdbRetestFailover <- o .: "userdb-retest-failover" - appUserdbSyncWithin <- o .:? "userdb-sync-within" - appUserdbSyncInterval <- o .: "userdb-sync-interval" + -- appUserRetestFailover <- o .: "userdb-retest-failover" + appUserSyncWithin <- o .:? "user-sync-within" + appUserSyncInterval <- o .: "user-sync-interval" appSynchroniseAvsUsersWithin <- o .:? "synchronise-avs-users-within" appSynchroniseAvsUsersInterval <- o .: "synchronise-avs-users-interval" From aa893062f199e376fab22a9f514667b0e536dfb7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 18:16:10 +0100 Subject: [PATCH 033/178] chore(ldap): refactor ldapLogin type --- src/Auth/LDAP.hs | 9 +++++---- src/Foundation/Instances.hs | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index b7a03d4a9..9064a83f4 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -263,6 +263,7 @@ campusForm = do <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing +-- TODO: reintroduce Failover ldapLogin :: forall site. ( YesodAuth site , RenderMessage site CampusMessage @@ -271,10 +272,10 @@ ldapLogin :: forall site. , RenderMessage site ADInvalidCredentials , Button site ButtonSubmit ) - => (LdapConf, LdapPool) -- TODO: reintroduce Failover - -> FailoverMode + => LdapConf + -> LdapPool -> AuthPlugin site -ldapLogin pool mode = AuthPlugin{..} +ldapLogin conf@LdapConf{..} pool = AuthPlugin{..} where apName :: Text apName = apLdap @@ -285,7 +286,7 @@ ldapLogin pool mode = AuthPlugin{..} tp <- getRouteToParent resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do - ldapResult <- withLdap _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do + ldapResult <- withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 8ab8d9beb..df14e7de3 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -142,7 +142,7 @@ instance YesodAuth UniWorX where authenticate = UniWorX.authenticate authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes - [ flip campusLogin campusUserFailoverMode <$> appLdapPool + [ uncurry ldapLogin <$> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin ] From 84d7890ae4644c3a89bc88ca871f76d5b2a49e7c Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 18:32:14 +0100 Subject: [PATCH 034/178] chore(auth): oauth2User->azureUser --- src/Auth/OAuth2.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index a810d43e6..c3b775b7a 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -7,7 +7,7 @@ module Auth.OAuth2 ( apAzure , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage - , oauth2User + , azureUser , AzureUserException(..) , oauth2MockServer , mockPluginName @@ -46,13 +46,13 @@ azureUserPreferredLanguage = "preferredLanguage" -- | User lookup in an OAuth2 database with given credentials -oauth2User :: ( MonadUnliftIO m - -- , MonadThrow m - ) - => AzureConf - -> Creds site - -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])]) -oauth2User _conf _creds = fmap throwLeft . liftIO . runExceptT $ do +azureUser :: ( MonadUnliftIO m + -- , MonadThrow m + ) + => AzureConf + -> Creds site + -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])]) +azureUser _conf _creds = fmap throwLeft . liftIO . runExceptT $ do results <- return [] -- TODO case results of [] -> throwE AzureUserNoResult From 9cbc35c263e573ee0a281e24443bf1e5bcad0409 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 18:32:36 +0100 Subject: [PATCH 035/178] chore(users): add azure id to AddUserData --- src/Utils/Users.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index 2339fbed5..a2eeb32f6 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -12,10 +12,9 @@ module Utils.Users import Import -data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin + +data AuthenticationKind = AuthKindLDAP | AuthKindAzure | AuthKindPWHash | AuthKindNoLogin deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Universe, Finite) ---instance Universe AuthenticationKind ---instance Finite AuthenticationKind embedRenderMessage ''UniWorX ''AuthenticationKind id nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2 @@ -49,10 +48,12 @@ data AddUserData = AddUserData , audPinPassword :: Maybe Text , audEmail :: UserEmail , audIdent :: UserIdent - , audAuth :: AuthenticationKind + , audAuth :: AuthenticationKind + , audAzureId :: Maybe UUID } --- | Adds a new user to database, no background jobs are scheduled, no notifications send + +-- | Adds a new user to database; no background jobs are scheduled, no notifications sent addNewUser :: AddUserData -> Handler (Maybe UserId) addNewUser AddUserData{..} = do now <- liftIO getCurrentTime @@ -78,6 +79,8 @@ addNewUser AddUserData{..} = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = audFPersonalNumber + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = audAzureId , userLastAuthentication = Nothing , userEmail = audEmail , userDisplayName = audDisplayName @@ -98,4 +101,4 @@ addNewUser AddUserData{..} = do , userMatrikelnummer = audMatriculation , userAuthentication = mkAuthMode audAuth } - runDB $ insertUnique newUser \ No newline at end of file + runDB $ insertUnique newUser \ No newline at end of file From 514bca5257fbd4100475145bdf359a213f1df291 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 18:37:28 +0100 Subject: [PATCH 036/178] chore: rename setting --- src/Jobs/Crontab.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 15819e6de..c65dd414f 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -310,10 +310,10 @@ determineCrontab = execWriterT $ do return (nextEpoch, nextInterval, nextIntervalTime, numIntervals) if - | Just syncWithin <- appUserdbSyncWithin + | Just syncWithin <- appUserSyncWithin , Just cInterval <- appJobCronInterval -> do - nextIntervals <- getNextIntervals syncWithin appUserdbSyncInterval cInterval + nextIntervals <- getNextIntervals syncWithin appUserSyncInterval cInterval forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do tell $ HashMap.singleton @@ -325,8 +325,8 @@ determineCrontab = execWriterT $ do Cron { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ toTimeOfDay 23 30 0 $ utctDay nextIntervalTime , cronRepeat = CronRepeatNever - , cronRateLimit = appUserdbSyncInterval - , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appUserdbSyncInterval nextIntervalTime + , cronRateLimit = appUserSyncInterval + , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appUserSyncInterval nextIntervalTime } | otherwise -> return () From a1ba004efa775a93045570bab44184492329fba2 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 18:37:59 +0100 Subject: [PATCH 037/178] chore(messages): add message for Azure auth kind --- messages/uniworx/categories/user/de-de-formal.msg | 1 + messages/uniworx/categories/user/en-eu.msg | 1 + 2 files changed, 2 insertions(+) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 128bf1cdf..3b9ee9b1c 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -97,6 +97,7 @@ UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen UserIsSupervisor: Ist Ansprechpartner AuthKindLDAP: Fraport AG Kennung +AuthKindAzure: Azure-Login AuthKindPWHash: FRADrive Kennung AuthKindNoLogin: Kein Login möglich Name !ident-ok: Name diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index a603bfe23..62069247e 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -97,6 +97,7 @@ UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised UserIsSupervisor: Is supervisor AuthKindLDAP: Fraport AG account +AuthKindAzure: Azure login AuthKindPWHash: FRADrive account AuthKindNoLogin: No login Name: Name From c65dc04e8ffd1b486e31342fb087b05fedfbe2f8 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 20:05:28 +0100 Subject: [PATCH 038/178] chore: add missing AuthAzure case --- src/Utils/Users.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index a2eeb32f6..7c35da5fb 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -20,6 +20,7 @@ nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2 mkAuthMode :: AuthenticationKind -> AuthenticationMode mkAuthMode AuthKindLDAP = AuthLDAP +mkAuthMode AuthKindAzure = AuthAzure mkAuthMode AuthKindPWHash = AuthPWHash "" mkAuthMode AuthKindNoLogin = AuthNoLogin From 264aaab24c1303857a244c93ce495e218fce9aed Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sun, 28 Jan 2024 20:05:52 +0100 Subject: [PATCH 039/178] chore: campus->ldap --- src/Handler/Utils/Users.hs | 6 +++--- src/Jobs/HealthReport.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5c85c9c73..0ef0eb1d2 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -24,7 +24,7 @@ module Handler.Utils.Users ) where import Import -import Auth.LDAP (campusUserMatr') +import Auth.LDAP (ldapUserMatr') import Foundation.Yesod.Auth (upsertCampusUser) import Crypto.Hash (hashlazy) @@ -241,7 +241,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) doLdap userMatr = do ldapPool' <- getsYesod $ view _appLdapPool fmap join . for ldapPool' $ \ldapPool -> do - ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr + ldapData <- ldapUserMatr' ldapPool FailoverUnlimited userMatr for ldapData $ upsertCampusUser UpsertCampusUserGuessUser let diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 68ada28f3..56092fc7c 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -110,7 +110,7 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _ dispatchHealthCheckLDAPAdmins :: Handler HealthReport dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do ldapPool' <- getsYesod appLdapPool - reTestAfter <- getsYesod $ view _appUserdbRetestFailover +--reTestAfter <- getsYesod $ view _appUserdbRetestFailover case ldapPool' of Just ldapPool -> do ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do @@ -123,7 +123,7 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) -> let hCampusExc :: CampusUserException -> Handler (Sum Integer) hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err) - in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds apLdap adminIdent []) + in handle hCampusExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent []) if | numAdmins >= 1 -> return $ numResolved % numAdmins | otherwise -> return 0 From 2763d2012a85fa3d72bb8292675b55689abc6bee Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 29 Jan 2024 00:45:43 +0000 Subject: [PATCH 040/178] chore(auth): provide oauth2 test users yaml --- shell.nix | 5 +- test/Database/test-users.yaml | 231 ++++++++++++++++++++++++++++++++++ 2 files changed, 235 insertions(+), 1 deletion(-) create mode 100644 test/Database/test-users.yaml diff --git a/shell.nix b/shell.nix index 329dd7549..9c43c44cf 100644 --- a/shell.nix +++ b/shell.nix @@ -9,7 +9,7 @@ let haskellPackages = pkgs.haskellPackages; - oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=11548e5aacca29c6ba389a62bca3d7a80d54eb6f&ref=refresh-tokens").packages.x86_64-linux; + oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=02510301ff4536f63182b798ca3551406c7e1aab&ref=refresh-tokens").packages.x86_64-linux; oauth2MockServer = oauth2Flake.default; mkOauth2DB = oauth2Flake.mkOauth2DB; @@ -297,6 +297,9 @@ in pkgs.mkShell { ''; OAUTH2_HBA = oauth2Hba; OAUTH2_DB_SCHEMA = oauth2Schema; + OAUTH2_TEST_USERS = ./test/Database/test-users.yaml; + OAUTH2_SERVER_PORT = 9443; + OAUTH2_DB_PORT = 9444; nativeBuildInputs = [develop inDevelop killallUni2work diffRunning oauth2MockServer] ++ (with pkgs; [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client diff --git a/test/Database/test-users.yaml b/test/Database/test-users.yaml new file mode 100644 index 000000000..17ea6d1ba --- /dev/null +++ b/test/Database/test-users.yaml @@ -0,0 +1,231 @@ +# SPDX-FileCopyrightText: 2024 David Mosbach +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +special-users: + + - default: &default-user + userIdent: null + userAuthentication: AuthLDAP + userLastAuthentication: null + userTokensIssuedAfter: null + userMatrikelnummer: null + userEmail: "" + userDisplayEmail: null + userDisplayName: null + userSurname: "" + userFirstName: "" + userTitle: null + userMaxFavourites: userDefaultMaxFavourites + userMaxFavouriteTerms: userDefaultMaxFavouriteTerms + userTheme: ThemeDefault + userDateTimeFormat: userDefaultDateTimeFormat + userDateFormat: userDefaultDateFormat + userTimeFormat: userDefaultTimeFormat + userDownloadFiles: userDefaultDownloadFiles + userWarningDays: userDefaultWarningDays + userLanguages: null + userCreated: now + userNotificationSettings: def + userLastLdapSynchronisation: null + userLdapPrimaryKey: null + userCsvOptions: def + userSex: null + userBirthday: null + userShowSex: userDefaultShowSex + userTelephone: null + userMobile: null + userCompanyPersonalNumber: null + userCompanyDepartment: null + userPinPassword: null + userPostAddress: null + userPostLastUpdate: null + userPrefersPostal: true + userExamOfficeGetSynced: userDefaultExamOfficeGetSynced + userExamOfficeGetLabels: userDefaultExamOfficeGetLabels + + - gkleen: + <<: *default-user + userIdent: "G.Kleen@campus.lmu.de" + userLastAuthentication: now + userTokensIssuedAfter: now + userEmail: "G.Kleen@campus.lmu.de" + userDisplayEmail: "gregor.kleen@ifi.lmu.de" + userDisplayName: "Gregor Kleen" + userSurname: "Kleen" + userFirstName: "Gregor Julius Arthur" + userMaxFavourites: 6 + userMaxFavouriteTerms: 1 + userLanguages: ["en"] + # userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } + userSex: SexMale + userCompanyPersonalNumber: "00000" + userPostAddress: "Büro 127 \nMathematisches Institut der Ludwig-Maximilians-Universität München \nTheresienstr. 39 \nD-80333 München" + + - fhamann: + <<: *default-user + userIdent: "felix.hamann@campus.lmu.de" + userEmail: "noEmailKnown" + userDisplayEmail: "felix.hamann@campus.lmu.de" + userDisplayName: "Felix Hamann" + userSurname: "Hamann" + userFirstName: "Felix" + # userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } + userSex: SexMale + userPinPassword: "tomatenmarmelade" + userPostAddress: "Erdbeerweg 24 \n12345 Schlumpfhausen \nTraumland" + + - jost: + <<: *default-user + userIdent: "jost@tcs.ifi.lmu.de" + userAuthentication: pwSimple + userMatrikelnummer: "12345678" + userEmail: "S.Jost@Fraport.de" + userDisplayEmail: "jost@tcs.ifi.lmu.de" + userDisplayName: "Steffen Jost" + userSurname: "Jost" + userFirstName: "Steffen" + userTitle: "Dr." + userMaxFavourites: 14 + userMaxFavouriteTerms: 4 + userTheme: ThemeMossGreen + userSex: SexMale + # userBirthday = Just $ n_day $ 35 * (-365) + userTelephone: "+49 69 690-71706" + userMobile: "0173 69 99 646" + userCompanyPersonalNumber: "57138" + userCompanyDepartment: "AVN-AR2" + + - maxMuster: + <<: *default-user + userIdent: "max@campus.lmu.de" + userLastAuthentication: now + userMatrikelnummer: "1299" + userEmail: "max@campus.lmu.de" + userDisplayEmail: "max@max.com" + userDisplayName: "Max Musterstudent" + userSurname: "Musterstudent" + userFirstName: "Max" + userMaxFavourites: 7 + userTheme: ThemeAberdeenReds + userLanguages: ["de"] + userSex: SexMale + # userBirthday = Just $ n_day $ 27 * (-365) + userPrefersPostal: false + + - tinaTester: + <<: *default-user + userIdent: "tester@campus.lmu.de" + userAuthentication: null + userMatrikelnummer: "999" + userEmail: "tester@campus.lmu.de" + userDisplayEmail: "tina@tester.example" + userDisplayName: "Tina Tester" + userSurname: "vön Tërrör¿" + userFirstName: "Sabrina" + userTitle: "Magister" + userMaxFavourites: 5 + userTheme: ThemeAberdeenReds + userLanguages: ["sn"] + userSex: SexNotApplicable + # userBirthday = Just $ n_day 3 + userCompanyPersonalNumber: "12345" + userPrefersPostal: false + + - svaupel: + <<: *default-user + userIdent: "vaupel.sarah@campus.lmu.de" + userEmail: "vaupel.sarah@campus.lmu.de" + userDisplayEmail: "vaupel.sarah@campus.lmu.de" + userDisplayName: "Sarah Vaupel" + userSurname: "Vaupel" + userFirstName: "Sarah" + userMaxFavourites: 14 + userMaxFavouriteTerms: 4 + userTheme: ThemeMossGreen + userLanguages: null + userSex: SexFemale + userPrefersPostal: false + + - sbarth: + <<: *default-user + userIdent: "Stephan.Barth@campus.lmu.de" + userEmail: "Stephan.Barth@lmu.de" + userDisplayEmail: "stephan.barth@ifi.lmu.de" + userDisplayName: "Stephan Barth" + userSurname: "Barth" + userFirstName: "Stephan" + userTheme: ThemeMossGreen + userSex: SexMale + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + - _stranger1: + userIdent: "AVSID:996699" + userEmail: "E996699@fraport.de" + userDisplayEmail: "" + userDisplayName: "Stranger One" + userSurname: "One" + userFirstName: "Stranger" + userTheme: ThemeMossGreen + userSex: SexMale + userCompanyPersonalNumber: "E996699" + userCompanyDepartment: "AVN-Strange" + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + - _stranger2: + userIdent: "AVSID:669966" + userEmail: "E669966@fraport.de" + userDisplayEmail: "" + userDisplayName: "Stranger Two" + userSurname: "Stranger" + userFirstName: "Two" + userTheme: ThemeMossGreen + userSex: SexMale + userCompanyPersonalNumber: "669966" + userCompanyDepartment: "AVN-Strange" + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + - _stranger3: + userIdent: "AVSID:6969" + userEmail: "E6969@fraport.de" + userDisplayEmail: "" + userDisplayName: "Stranger 3 Three" + userSurname: "Three" + userFirstName: "Stranger" + userTheme: ThemeMossGreen + userSex: SexMale + userCompanyPersonalNumber: "E996699" + userCompanyDepartment: "AVN-Strange" + userPostAddress: "Kartoffelweg 12 \n666 Höllensumpf \nFreiland" + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + +random-users: + firstNames: [ "James", "John", "Robert", "Michael" + , "William", "David", "Mary", "Richard" + , "Joseph", "Thomas", "Charles", "Daniel" + , "Matthew", "Patricia", "Jennifer", "Linda" + , "Elizabeth", "Barbara", "Anthony", "Donald" + , "Mark", "Paul", "Steven", "Andrew" + , "Kenneth", "Joshua", "George", "Kevin" + , "Brian", "Edward", "Susan", "Ronald" + ] + surnames: [ "Smith", "Johnson", "Williams", "Brown" + , "Jones", "Miller", "Davis", "Garcia" + , "Rodriguez", "Wilson", "Martinez", "Anderson" + , "Taylor", "Thomas", "Hernandez", "Moore" + , "Martin", "Jackson", "Thompson", "White" + , "Lopez", "Lee", "Gonzalez", "Harris" + , "Clark", "Lewis", "Robinson", "Walker" + , "Perez", "Hall", "Young", "Allen" + ] + middlenames: [ null, "Jamesson" ] + From 5a023a9e32d5493871e1ac36c49330446bf29bc1 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 29 Jan 2024 21:34:39 +0000 Subject: [PATCH 041/178] chore(auth): added function for user queries to auth servers --- src/Application.hs | 2 +- src/Auth/OAuth2.hs | 42 ++++++++++++++++++++++++++++++++++++++---- 2 files changed, 39 insertions(+), 5 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 8b9a21739..e4c75668b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -337,7 +337,7 @@ makeFoundation appSettings''@AppSettings{..} = do return . uncurry p $ fromJust mArgs appAuthPlugins <- liftIO $ sequence [ - return oauth2MockServer + (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT" , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2" ] diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index c3637c0f0..8be0e5111 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -6,13 +6,19 @@ module Auth.OAuth2 ( AzureUserException(..) +, azurePluginName , oauth2MockServer , mockPluginName +, queryOauth2User ) where import Data.Text -import Import.NoFoundation +import Import.NoFoundation hiding (unpack) + +import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException) + +import System.Environment (lookupEnv) import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2.Prelude @@ -25,6 +31,9 @@ data AzureUserException = AzureUserError instance Exception AzureUserException +azurePluginName :: Text +azurePluginName = "azureadv2" + ---------------------------------------- ---- OAuth2 development auth plugin ---- ---------------------------------------- @@ -37,8 +46,8 @@ instance FromJSON UserID where parseJSON = withObject "UserID" $ \o -> UserID <$> o .: "id" -oauth2MockServer :: YesodAuth m => AuthPlugin m -oauth2MockServer = +oauth2MockServer :: YesodAuth m => String -> AuthPlugin m +oauth2MockServer port = let oa = OAuth2 { oauth2ClientId = "42" , oauth2ClientSecret = Just "shhh" @@ -46,7 +55,7 @@ oauth2MockServer = , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token" , oauth2RedirectUri = Nothing } - mockServerURL = "http://localhost:9443" + mockServerURL = "http://localhost:" <> fromString port profileSrc = fromString $ mockServerURL <> "/users/me" in authOAuth2 mockPluginName oa $ \manager token -> do (UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc @@ -56,4 +65,29 @@ oauth2MockServer = , credsExtra = setExtra token userResponse } +---------------------- +---- User Queries ---- +---------------------- + +data UserData = UD +instance FromJSON UserData where + parseJSON _ = pure UD + +queryOauth2User :: forall m . (MonadIO m, MonadThrow m) + => Text + -> Text + -> m (Either JSONException UserData) +queryOauth2User authPlugin userID = do + baseUrl <- liftIO mkBaseUrl + req <- parseRequest $ "GET " ++ baseUrl ++ unpack userID + -- TODO get new token & put token in auth header + getResponseBody <$> httpJSONEither @m @UserData req + where + mkBaseUrl :: IO String + mkBaseUrl + | authPlugin == azurePluginName = return "https://graph.microsoft.com/v1.0/users/" + | authPlugin == mockPluginName = do + Just port <- lookupEnv "OAUTH2_SERVER_PORT" + return $ "http://localhost:" ++ port ++ "/users/query?id=" + | otherwise = fail $ unpack authPlugin From c8fa509ace7cc0746ac1df5678b49e393f39d397 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 30 Jan 2024 05:06:06 +0000 Subject: [PATCH 042/178] feat(auth): tokens can be stored & refreshed --- src/Application.hs | 4 +-- src/Auth/OAuth2.hs | 70 ++++++++++++++++++++++++++++++++++---------- src/Utils/Session.hs | 3 +- 3 files changed, 58 insertions(+), 19 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index e4c75668b..08fef42ee 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -62,7 +62,7 @@ import Jobs import qualified Data.Text.Encoding as Text import qualified Data.Text as Text -import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2) +import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped) import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS @@ -338,7 +338,7 @@ makeFoundation appSettings''@AppSettings{..} = do appAuthPlugins <- liftIO $ sequence [ (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT" - , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2" + , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2" ] diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 8be0e5111..e4dc20433 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -9,9 +9,10 @@ module Auth.OAuth2 , azurePluginName , oauth2MockServer , mockPluginName -, queryOauth2User +, queryOAuth2User ) where +import Data.Maybe (fromJust) import Data.Text import Import.NoFoundation hiding (unpack) @@ -21,7 +22,7 @@ import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException) import System.Environment (lookupEnv) import Yesod.Auth.OAuth2 -import Yesod.Auth.OAuth2.Prelude +import Yesod.Auth.OAuth2.Prelude hiding (encodeUtf8) data AzureUserException = AzureUserError @@ -73,21 +74,58 @@ data UserData = UD instance FromJSON UserData where parseJSON _ = pure UD -queryOauth2User :: forall m . (MonadIO m, MonadThrow m) +queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m) => Text -> Text -> m (Either JSONException UserData) -queryOauth2User authPlugin userID = do - baseUrl <- liftIO mkBaseUrl - req <- parseRequest $ "GET " ++ baseUrl ++ unpack userID - -- TODO get new token & put token in auth header - getResponseBody <$> httpJSONEither @m @UserData req - where - mkBaseUrl :: IO String - mkBaseUrl - | authPlugin == azurePluginName = return "https://graph.microsoft.com/v1.0/users/" - | authPlugin == mockPluginName = do - Just port <- lookupEnv "OAUTH2_SERVER_PORT" - return $ "http://localhost:" ++ port ++ "/users/query?id=" - | otherwise = fail $ unpack authPlugin +queryOAuth2User authPlugin userID = do + (queryUrl, tokenUrl) <- liftIO $ mkBaseUrls authPlugin + req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID + mTokens <- lookupSessionJson SessionOAuth2Token + unless (isJust mTokens) . fail $ "Tried to load sesion Oauth2 tokens, but there are none" + eNewToken <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl (authPlugin == azurePluginName) + case eNewToken of + Left e -> return $ Left e + Right newTokens -> do + setSessionJson SessionOAuth2Token newTokens + getResponseBody <$> httpJSONEither @m @UserData (req + { secure = authPlugin == azurePluginName + , requestHeaders = [("Authorization", encodeUtf8 . atoken . fromJust $ fst newTokens)] }) + +mkBaseUrls :: Text -> IO (String, String) +mkBaseUrls authPlugin + | authPlugin == azurePluginName = do + Just tenantID <- lookupEnv "AZURE_TENANT_ID" + return ( "https://graph.microsoft.com/v1.0/users/" + , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) + | authPlugin == mockPluginName = do + Just port <- lookupEnv "OAUTH2_SERVER_PORT" + let base = "http://localhost:" ++ port + return ( base ++ "/users/query?id=" + , base ++ "/token" ) + | otherwise = fail $ "Unsupported auth plugin: " ++ unpack authPlugin + + +refreshOAuth2Token :: forall m x. (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m, x ~ (Maybe AccessToken, Maybe RefreshToken)) + => x + -> String + -> Bool + -> m (Either JSONException x) +refreshOAuth2Token (_, refreshToken) url secure + | isJust refreshToken = do + req <- parseRequest $ "POST " ++ url + let + body = + [ ("grant_type", "refresh_token") + , ("refresh_token", encodeUtf8 . rtoken $ fromJust refreshToken) + , ("scope", "") -- TODO must be subset of previously requested scopes. space separated list + ] + body' <- if secure then do + Just clientID <- liftIO $ lookupEnv "CLIENT_ID" + Just clientSecret <- liftIO $ lookupEnv "CLIENT_SECRET" + return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret)] + else return body + getResponseBody <$> httpJSONEither @m @x (urlEncodedBody body' req{ secure = secure }) + | otherwise = fail "Could not refresh access token. Refresh token is missing." + diff --git a/src/Utils/Session.hs b/src/Utils/Session.hs index ef104b29c..4b5e5c378 100644 --- a/src/Utils/Session.hs +++ b/src/Utils/Session.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -20,6 +20,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags | SessionLang | SessionError | SessionFiles + | SessionOAuth2Token deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) From 1cdb20eb60ca8927b9b81cf11c82b88907e59e17 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 11:20:44 +0100 Subject: [PATCH 043/178] chore(ldap): fix user lookup types --- src/Auth/LDAP.hs | 108 ++++++++++++++++++++-------------------- src/Ldap/Client/Pool.hs | 2 +- 2 files changed, 54 insertions(+), 56 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 9064a83f4..8ad8c2aab 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -10,7 +10,7 @@ module Auth.LDAP , ldapLogin , CampusUserException(..) , ldapUser, ldapUser', ldapUser'' - , ldapUserReTest, ldapUserReTest' +--, ldapUserReTest, ldapUserReTest' , ldapUserMatr, ldapUserMatr' , CampusMessage(..) , ldapPrimaryKey @@ -131,18 +131,21 @@ makePrisms ''CampusUserException ldapUserWith :: ( MonadUnliftIO m , MonadCatch m + --, MonadLogger m ) - => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap - -> Failover (LdapConf, LdapPool) - -> FailoverMode - -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) - -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) + -- ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap + -- -> (LdapConf, LdapPool) + -- -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) + -- -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) + -- ) + => ( LdapPool + -> (Ldap -> m (Either CampusUserException (Ldap.AttrList []))) + -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) ) - -> Failover (LdapConf, LdapPool) - -> FailoverMode + -> (LdapConf, LdapPool) -> Creds site -> m (Either CampusUserException (Ldap.AttrList [])) -ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do +ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do lift $ Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do @@ -156,73 +159,70 @@ ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapErro _otherwise -> throwE CampusUserAmbiguous -ldapUserReTest :: ( MonadUnliftIO m - , MonadMask m - , MonadLogger m - ) - => Failover (LdapConf, LdapPool) - -> (Nano -> Bool) - -> FailoverMode - -> Creds site - -> m (Ldap.AttrList []) -ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds - -ldapUserReTest' :: ( MonadMask m - , MonadLogger m - , MonadUnliftIO m - ) - => Failover (LdapConf, LdapPool) - -> (Nano -> Bool) - -> FailoverMode - -> User - -> m (Maybe (Ldap.AttrList [])) -ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent []) - where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey +-- TODO: reintroduce once failover has been reimplemented +-- ldapUserReTest :: ( MonadUnliftIO m +-- , MonadMask m +-- , MonadLogger m +-- ) +-- => Failover (LdapConf, LdapPool) +-- -> (Nano -> Bool) +-- -> FailoverMode +-- -> Creds site +-- -> m (Ldap.AttrList []) +-- ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds +-- +-- ldapUserReTest' :: ( MonadMask m +-- , MonadLogger m +-- , MonadUnliftIO m +-- ) +-- => Failover (LdapConf, LdapPool) +-- -> (Nano -> Bool) +-- -> FailoverMode +-- -> User +-- -> m (Maybe (Ldap.AttrList [])) +-- ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} +-- = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent []) +-- where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey ldapUser :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> Creds site -> m (Ldap.AttrList []) -ldapUser pool mode creds = throwLeft =<< ldapUserWith withLdapFailover pool mode creds +ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds ldapUser' :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> User -> m (Maybe (Ldap.AttrList [])) -ldapUser' pool mode User{userIdent} - = ldapUser'' pool mode $ CI.original userIdent +ldapUser' pool User{userIdent} + = ldapUser'' pool $ CI.original userIdent ldapUser'' :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> Text -> m (Maybe (Ldap.AttrList [])) -ldapUser'' pool mode ident - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool mode (Creds apLdap ident []) +ldapUser'' pool ident + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool (Creds apLdap ident []) ldapUserMatr :: ( MonadUnliftIO m , MonadMask m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> UserMatriculation -> m (Ldap.AttrList []) -ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do +ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword results <- findUserMatr conf ldap userMatr [] case results of @@ -232,14 +232,12 @@ ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return < ldapUserMatr' :: ( MonadMask m , MonadUnliftIO m - , MonadLogger m + --, MonadLogger m ) - => Failover (LdapConf, LdapPool) - -> FailoverMode + => (LdapConf, LdapPool) -> UserMatriculation -> m (Maybe (Ldap.AttrList [])) -ldapUserMatr' pool mode - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool mode +ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool newtype ADInvalidCredentials = ADInvalidCredentials ADError diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 47eb4147c..96216e354 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later From 8e2a98c12b7e2d8d8a00080f5b96d5a3fe3e7124 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 11:42:45 +0100 Subject: [PATCH 044/178] chore(foundation): fix ldap auth and user lookup --- src/Foundation/Yesod/Auth.hs | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 541cf7857..9d0ffeed8 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -4,11 +4,11 @@ module Foundation.Yesod.Auth ( authenticate - -- , ldapLookupAndUpsert + , ldapLookupAndUpsert , upsertLdapUser, upsertAzureUser , decodeLdapUserTest, decodeAzureUserTest , CampusUserConversionException(..) - , campusUserFailoverMode, updateUserLanguage + , updateUserLanguage ) where import Import.NoFoundation hiding (authenticate) @@ -36,7 +36,6 @@ import qualified Data.Text.Encoding as Text import qualified Data.ByteString as ByteString import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.List.PointedList as PointedList import qualified Data.UUID as UUID @@ -110,10 +109,8 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData UserSourceConfSingleSource (UserSourceLdap _) | Just upsertMode' <- upsertMode -> do - -- TODO WIP ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool - ldapConf <- mkFailover $ PointedList.singleton ldapPool - ldapData <- ldapUser ldapConf FailoverNone Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..} + ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..} $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData _other @@ -158,15 +155,21 @@ _upsertUserMode mMode cs@Creds{..} defaultOther = apHash --- TODO: rewrite --- ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) --- ldapLookupAndUpsert ident = --- getsYesod (view _appLdapPool) >>= \case --- Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." --- Just ldapPool -> --- campusUser'' ldapPool campusUserFailoverMode ident >>= \case --- Nothing -> throwM CampusUserNoResult --- Just ldapResponse -> upsertLdapUser UpsertCampusUserGuessUser ldapResponse +ldapLookupAndUpsert :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadMask m + , MonadUnliftIO m + ) + => Text + -> SqlPersistT m (Entity User) +ldapLookupAndUpsert ident = + getsYesod (view _appLdapPool) >>= \case + Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." + Just ldapPool -> + ldapUser'' ldapPool ident >>= \case + Nothing -> throwM CampusUserNoResult + Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse -- | Upsert User DB according to given LDAP data (does not query LDAP itself) @@ -579,7 +582,4 @@ updateUserLanguage Nothing = runMaybeT $ do setRegisteredCookie CookieLang lang return lang -campusUserFailoverMode :: FailoverMode -campusUserFailoverMode = FailoverUnlimited - embedRenderMessage ''UniWorX ''CampusUserConversionException id From af09e028013064b0e15c9dfb25601f1bcece6618 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 13:52:33 +0100 Subject: [PATCH 045/178] chore(lms): add missing user fields for fake user --- src/Handler/LMS/Fake.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index cd7392760..6276f07bc 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -92,6 +92,8 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u userCreated = now userLastLdapSynchronisation = Nothing userLdapPrimaryKey = Nothing + userLastAzureSynchronisation = Nothing + userAzurePrimaryKey = Nothing userTokensIssuedAfter = Nothing userFirstName = Text.unwords firstNames userTitle = Nothing From c8350722a41bbfae1b4c862fb9958d0e6f8102f1 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 14:01:54 +0100 Subject: [PATCH 046/178] chore(ldap): migrate more campusUser usages --- src/Handler/Admin/Ldap.hs | 8 ++++---- src/Handler/Utils/Avs.hs | 5 +++-- src/Handler/Utils/Users.hs | 6 +++--- src/Jobs/Handler/SynchroniseUserdb.hs | 10 +++++----- src/Jobs/HealthReport.hs | 3 ++- 5 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index c3ed22c2a..27e88eab5 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -16,7 +16,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -- import qualified Data.Set as Set -import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException()) +import Foundation.Yesod.Auth (decodeLdapUserTest,ldapLookupAndUpsert,CampusUserConversionException()) import Handler.Utils import qualified Ldap.Client as Ldap @@ -36,8 +36,8 @@ postAdminLdapR = do Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing Just ldapPool -> do addMessage Info $ text2Html "Input for LDAP test received." - ldapData <- campusUser'' ldapPool campusUserFailoverMode lid - decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData + ldapData <- ldapUser'' ldapPool lid + decodedErr <- decodeLdapUserTest (pure $ CI.mk lid) $ concat ldapData whenIsLeft decodedErr $ addMessageI Error return ldapData mbLdapData <- formResultMaybe presult procFormPerson diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 160a3f337..0f0b8094b 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -421,7 +421,7 @@ upsertAvsUserById api = do (_:_) -> throwM $ AvsUserAmbiguous api [] -> do upsRes :: Either SomeException (Entity User) - <- try $ ldapLookupAndUpsert persNo + <- try $ ldapLookupAndUpsert persNo -- TODO: do azure lookup and upsert if appropriate $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway @@ -460,7 +460,8 @@ upsertAvsUserById api = do , audPinPassword = userPin , audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , audIdent = fakeIdent -- use AvsPersonId instead - , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known + , audAuth = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known + , audAzureId = Nothing -- TODO } mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 0ef0eb1d2..45b738c07 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -25,7 +25,7 @@ module Handler.Utils.Users import Import import Auth.LDAP (ldapUserMatr') -import Foundation.Yesod.Auth (upsertCampusUser) +import Foundation.Yesod.Auth (upsertLdapUser) import Crypto.Hash (hashlazy) @@ -241,8 +241,8 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) doLdap userMatr = do ldapPool' <- getsYesod $ view _appLdapPool fmap join . for ldapPool' $ \ldapPool -> do - ldapData <- ldapUserMatr' ldapPool FailoverUnlimited userMatr - for ldapData $ upsertCampusUser UpsertCampusUserGuessUser + ldapData <- ldapUserMatr' ldapPool userMatr + for ldapData $ upsertLdapUser UpsertUserGuessUser let getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation diff --git a/src/Jobs/Handler/SynchroniseUserdb.hs b/src/Jobs/Handler/SynchroniseUserdb.hs index 34069a90d..210977893 100644 --- a/src/Jobs/Handler/SynchroniseUserdb.hs +++ b/src/Jobs/Handler/SynchroniseUserdb.hs @@ -13,7 +13,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Auth.LDAP -import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser) +import Foundation.Yesod.Auth (CampusUserConversionException, upsertLdapUser, upsertAzureUser) import Jobs.Queue @@ -53,14 +53,14 @@ dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with LDAP|] -- reTestAfter <- getsYesod $ view _appUserdbRetestFailover -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user - ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user - void . lift $ upsertLdapUser (UpsertLdapUserLdapSync upsertIdent) ldapAttrs - UserSourceConfSingleSource (UserSourceAzure azureConf) -> + ldapAttrs <- MaybeT $ ldapUser ldapConf user + void . lift $ upsertLdapUser (UpsertUserSync upsertIdent) ldapAttrs + UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|] - void . lift $ upsertAzureUser (UpsertAzureUserSync upsertIdent) azureConf + void . lift $ upsertAzureUser (UpsertUserSync upsertIdent) azureConf where handleExc :: MaybeT DB a -> MaybeT DB a handleExc diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 56092fc7c..ea9ef1c19 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -123,7 +123,8 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) -> let hCampusExc :: CampusUserException -> Handler (Sum Integer) hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err) - in handle hCampusExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent []) + in handle hCampusExc $ Sum 1 <$ ldapUser ldapPool (Creds apLdap adminIdent []) + --in handle hCampusExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent []) if | numAdmins >= 1 -> return $ numResolved % numAdmins | otherwise -> return 0 From f4b8417deb61d6ce98caa5e0711702804ba13aff Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:50:19 +0100 Subject: [PATCH 047/178] chore(messages): add admin azure message --- messages/uniworx/categories/admin/de-de-formal.msg | 4 +++- messages/uniworx/categories/admin/en-eu.msg | 6 ++++-- messages/uniworx/utils/utils/de-de-formal.msg | 6 ++++-- messages/uniworx/utils/utils/en-eu.msg | 6 ++++-- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index f4c23696d..d346f9922 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -123,4 +123,6 @@ ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend -InterfaceWrite: Schreibend \ No newline at end of file +InterfaceWrite: Schreibend + +AdminUserAzureId !ident-ok: Azure-ID \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c035f54c0..a01275230 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Sarah Vaupel , Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -123,4 +123,6 @@ ProblemsInterfaceSince: Only considering successes and errors since InterfaceLastSynch: Last InterfaceSubtype: Affecting -InterfaceWrite: Write \ No newline at end of file +InterfaceWrite: Write + +AdminUserAzureId: Azure ID \ No newline at end of file diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 5ff122fb1..fb7d7c499 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2023 Steffen Jost ,Gregor Kleen ,Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Steffen Jost , Gregor Kleen , Sarah Vaupel , Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -158,4 +158,6 @@ SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetTypeNormal !ident-ok: Normal SheetTypeBonus !ident-ok: Bonus -InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten \ No newline at end of file +InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten + +InvalidUuid: Invalide UUID! \ No newline at end of file diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index f65004cd1..e9c71d44e 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Winnie Ros ,Steffen Jost +# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Sarah Vaupel , Winnie Ros , Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -158,4 +158,6 @@ SheetGradingPassAlways': Automatically passed when corrected SheetTypeNormal: Normal SheetTypeBonus: Bonus -InvalidFormAction: No action taken due to invalid form data \ No newline at end of file +InvalidFormAction: No action taken due to invalid form data + +InvalidUuid: Invalid UUID! \ No newline at end of file From 43bf25a5bd92ba89f62bc983f0d0724d08f0d05a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:50:56 +0100 Subject: [PATCH 048/178] chore(azure): implement azureUser variant --- src/Auth/OAuth2.hs | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index c3b775b7a..f30f4d7c1 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -7,12 +7,13 @@ module Auth.OAuth2 ( apAzure , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage - , azureUser - , AzureUserException(..) + , azureUser, azureUser' + , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous , oauth2MockServer , mockPluginName ) where +import qualified Data.CaseInsensitive as CI import Data.Text import Import.NoFoundation @@ -32,6 +33,8 @@ data AzureUserException = AzureUserError instance Exception AzureUserException +makePrisms ''AzureUserException + azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage :: Text azurePrimaryKey = "id" @@ -45,8 +48,9 @@ azureUserMobile = "mobilePhone" azureUserPreferredLanguage = "preferredLanguage" --- | User lookup in an OAuth2 database with given credentials -azureUser :: ( MonadUnliftIO m +-- | User lookup in Microsoft Graph with given credentials +azureUser :: ( MonadMask m + , MonadUnliftIO m -- , MonadThrow m ) => AzureConf @@ -59,6 +63,17 @@ azureUser _conf _creds = fmap throwLeft . liftIO . runExceptT $ do [res] -> return res _multiple -> throwE AzureUserAmbiguous +-- | User lookup in Microsoft Graph with given user +azureUser' :: ( MonadMask m + , MonadUnliftIO m + -- , MonadThrow m + ) + => AzureConf + -> User + -> m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])]) +azureUser' conf User{userIdent} + = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) []) + ---------------------------------------- ---- OAuth2 development auth plugin ---- From 24dbaf36bca4402d750d9c7ed69108f1d6d5fb4b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:51:25 +0100 Subject: [PATCH 049/178] chore(form): add uuidField --- src/Utils/Form.hs | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index e79761885..d6cf508f7 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost , Steffen Jost , Wolfgang Witt -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -19,7 +19,7 @@ import Settings import Utils.Parameters import Utils.Lens -import Text.Blaze (Markup) +import Text.Blaze (Markup, toMarkup) import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T import qualified Data.Char as C @@ -27,6 +27,7 @@ import qualified Data.Char as C import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Universe +import qualified Data.UUID as UUID import Data.List (nub, (!!)) import Data.Map.Lazy ((!)) @@ -81,6 +82,9 @@ import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded) import qualified Data.ByteString as BS +fvWidget :: FieldView site -> WidgetFor site () +fvWidget FieldView{..} = $(widgetFile "widgets/field-view/field-view") + ------------ -- Fields -- ------------ @@ -116,6 +120,17 @@ commentField msg = Field {..} fieldView _ _ _ _ _ = msg2widget msg fieldEnctype = UrlEncoded +uuidField :: Monad m => Field m UUID +uuidField = Field{..} + where + fieldParse = parseHelperGen $ maybe (Left $ tshow "Invalid UUID!") Right . UUID.fromText + fieldView fvId (toMarkup -> fvLabel) fvAttrs fvInput' fvRequired = fvWidget FieldView{..} + where fvTooltip = Nothing + fvErrors = either (Just . toMarkup) (const Nothing) fvInput' + fvInput = [whamlet||] + fvValue = either id UUID.toText fvInput' + fieldEnctype = UrlEncoded + -------------------- -- Field Settings -- -------------------- @@ -1257,10 +1272,6 @@ formSection formSectionTitle = do , fvInput = mempty }) -fvWidget :: FieldView site -> WidgetFor site () -fvWidget FieldView{..} = $(widgetFile "widgets/field-view/field-view") - - doFormHoneypots :: ( MonadHandler m , HasAppSettings (HandlerSite m) , YesodAuth (HandlerSite m) From f39de71c02d22fa144c90366f4720b19c2a3b9e8 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:52:30 +0100 Subject: [PATCH 050/178] chore(jobs): upsertAzureUser on synchronise user job with azure config --- src/Jobs/Handler/SynchroniseUserdb.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Jobs/Handler/SynchroniseUserdb.hs b/src/Jobs/Handler/SynchroniseUserdb.hs index 210977893..dab3233a0 100644 --- a/src/Jobs/Handler/SynchroniseUserdb.hs +++ b/src/Jobs/Handler/SynchroniseUserdb.hs @@ -11,8 +11,10 @@ import Import import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C +import qualified Data.UUID as UUID import Auth.LDAP +import Auth.OAuth2 import Foundation.Yesod.Auth (CampusUserConversionException, upsertLdapUser, upsertAzureUser) import Jobs.Queue @@ -44,23 +46,25 @@ dispatchJobSynchroniseUserdb numIterations epoch iteration dispatchJobSynchroniseUserdbUser :: UserId -> JobHandler UniWorX dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do - UniWorX{..} <- getYesod - case appUserSourceConf of - UserSourceConfSingleSource (UserSourceLdap ldapConf) -> + userSourceConf <- getsYesod $ view _appUserSourceConf + case userSourceConf of + UserSourceConfSingleSource (UserSourceLdap _ldapConf) -> runDB . void . runMaybeT . handleExc $ do + ldapPool <- MaybeT . getsYesod $ view _appLdapPool user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with LDAP|] -- reTestAfter <- getsYesod $ view _appUserdbRetestFailover -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user - ldapAttrs <- MaybeT $ ldapUser ldapConf user + ldapAttrs <- MaybeT $ ldapUser' ldapPool user void . lift $ upsertLdapUser (UpsertUserSync upsertIdent) ldapAttrs UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser - let upsertIdent = maybe userIdent CI.mk userAzurePrimaryKey + let upsertIdent = maybe userIdent (CI.mk . UUID.toText) userAzurePrimaryKey -- TODO: use userPrincipalName $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|] - void . lift $ upsertAzureUser (UpsertUserSync upsertIdent) azureConf + azureAttrs <- MaybeT $ azureUser' azureConf user + void . lift $ upsertAzureUser (UpsertUserSync upsertIdent) azureAttrs where handleExc :: MaybeT DB a -> MaybeT DB a handleExc From 3c4e6b62fbd765f431dbeab80a15b681ef47a644 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:53:30 +0100 Subject: [PATCH 051/178] chore: fix constructor names --- src/Handler/Admin/Test.hs | 4 ++-- src/Jobs.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index d89ca8ea6..e6acc5d5d 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -321,8 +321,8 @@ postAdminTestR = do
appJobCronInterval
#{tshow appJobCronInterval} -
appUserDbSyncWithin -
#{tshow appUserdbSyncWithin} +
appUserSyncWithin +
#{tshow appUserSyncWithin}
appSynchroniseAvsUsersWithin
#{tshow appSynchroniseAvsUsersWithin} |] diff --git a/src/Jobs.hs b/src/Jobs.hs index 79c17ba25..e24636724 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -493,7 +493,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker , Exc.Handler $ \case MailNotAvailable -> return $ Right () e -> return . Left $ SomeException e - , Exc.Handler $ \SynchroniseUserdbNoLdap -> return $ Right () -- TODO + , Exc.Handler $ \SynchroniseUserdbNoUserdb -> return $ Right () -- TODO #endif , Exc.Handler $ \(e :: SomeException) -> return $ Left e ] . fmap Right From 608d8a36615fd57c62f39da86beb1f0c1b16d966 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:53:58 +0100 Subject: [PATCH 052/178] chore(users): add missing azure id field for UsersAdd --- src/Handler/Users/Add.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 60374b803..c168009af 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -36,6 +36,7 @@ adminUserForm template = renderAForm FormStandard <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (audEmail <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (audIdent <$> template) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (audAuth <$> template <|> Just AuthKindLDAP) + <*> aopt uuidField (fslI MsgAdminUserAzureId) (audAzureId <$> template) -- | Like `addNewUser`, but starts background jobs and tries to notify users, if applicable (i.e. /= AuthNoLogin ) addNewUserNotify :: AddUserData -> Handler (Maybe UserId) From dfa774f6557153803cb233318be714812b705c38 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:54:20 +0100 Subject: [PATCH 053/178] chore(users): campusUser->ldapUser --- src/Handler/Users.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 9baf06c62..0a893e211 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -532,13 +532,13 @@ postAdminUserR uuid = do redirect $ AdminUserR uuid userAuthenticationAction = \case - BtnAuthLDAP -> do + BtnAuthLDAP -> do -- TODO WIP let campusHandler :: MonadPlus m => Auth.CampusUserException -> m a campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do Just pool <- getsYesod $ view _appLdapPool - void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) [] + void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) [] case campusResult of Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup _other From d9ed893b52c32c3bcc5868c874e49f4c6da8bd55 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 21:54:46 +0100 Subject: [PATCH 054/178] chore(application): fix ldapPool setup --- src/Application.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 8aa072a36..cac5ce2c1 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,David Mosbach +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -107,7 +107,7 @@ import Handler.Utils.Routes (classifyHandler) import qualified Data.Acid.Memory as Acid import qualified Web.ServerSession.Backend.Acid as Acid --- import qualified Ldap.Client as Ldap (Host(Plain, Tls)) +import qualified Ldap.Client as Ldap (Host(Plain, Tls)) import qualified Network.Minio as Minio @@ -241,7 +241,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appUserDbPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") @@ -313,17 +313,17 @@ makeFoundation appSettings''@AppSettings{..} = do -- forM_ ldapPool $ registerFailoverMetrics "ldap" -- TODO: reintroduce failover once UserDbFailover is implemented (see above) - ldapPool <- forOf (traverse . traverse) appLdapPoolConf $ \RessourcePoolConf{..} -> if + ldapPool <- fmap join . forM appLdapPoolConf $ \ResourcePoolConf{..} -> if | UserSourceConfSingleSource{..} <- appUserSourceConf - , UserSourceLdap LdapConf{..} <- usersrcSingleSource + , UserSourceLdap conf@LdapConf{..} <- usersrcSingleSource -> do -- set up a singleton ldap pool with no failover let ldapLabel = case ldapHost of Ldap.Plain str -> pack str <> ":" <> tshow ldapPort Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel - (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit + Just . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit | otherwise -- No LDAP pool to be initialized - -> return mempty + -> return Nothing -- Perform database migration using our application's logging settings. flip runReaderT tempFoundation $ @@ -778,7 +778,7 @@ shutdownApp app = do liftIO $ do Custom.purgePool $ appConnPool app for_ (appSmtpPool app) destroyAllResources - for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources + for_ (appLdapPool app) $ views _2 destroyAllResources for_ (appWidgetMemcached app) Memcached.close for_ (appMemcached app) $ views _memcachedConn Memcached.close release . fst $ appLogger app From aa81de74a4ce9fc3b3614747c724a27d36b9e528 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 22:02:48 +0100 Subject: [PATCH 055/178] chore(db-fill): add missing user fields --- test/Database/Fill.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index c1c657912..8e3905fd4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -105,6 +105,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userSex = Just SexMale , userBirthday = Nothing @@ -145,6 +147,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userSex = Just SexMale , userShowSex = userDefaultShowSex @@ -191,6 +195,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userSex = Just SexMale , userBirthday = Just $ n_day $ 35 * (-365) , userCsvOptions = def @@ -231,6 +237,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexMale , userBirthday = Just $ n_day $ 27 * (-365) @@ -311,6 +319,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexFemale , userBirthday = Nothing @@ -351,6 +361,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexMale , userBirthday = Nothing @@ -391,6 +403,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexMale , userBirthday = Nothing @@ -431,6 +445,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexMale , userBirthday = Nothing @@ -471,6 +487,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexMale , userBirthday = Nothing From 9c608070ae684101f199fa0d78ece9d994c0b24a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Jan 2024 22:08:55 +0100 Subject: [PATCH 056/178] chore(db-fill): add missing user fields contd --- test/Database/Fill.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8e3905fd4..c2334314b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -279,6 +279,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Just SexNotApplicable , userBirthday = Just $ n_day 3 @@ -569,6 +571,8 @@ fillDb = do , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = Nothing + , userLastAzureSynchronisation = Nothing + , userAzurePrimaryKey = Nothing , userCsvOptions = def , userSex = Nothing , userBirthday = Nothing From 453034100b38540a884ebfa4d46fdba04cf90b77 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Wed, 31 Jan 2024 14:32:49 +0000 Subject: [PATCH 057/178] feat(auth): admin handler can query user data --- shell.nix | 2 +- src/Auth/OAuth2.hs | 44 +++++++++++++++++++------------------ src/Handler/Admin/OAuth2.hs | 20 +++++++++++++---- 3 files changed, 40 insertions(+), 26 deletions(-) diff --git a/shell.nix b/shell.nix index 9c43c44cf..4b114f966 100644 --- a/shell.nix +++ b/shell.nix @@ -9,7 +9,7 @@ let haskellPackages = pkgs.haskellPackages; - oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=02510301ff4536f63182b798ca3551406c7e1aab&ref=refresh-tokens").packages.x86_64-linux; + oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=6fc2d621573e048b7ce2dabfc4887c7876055f8d&ref=user-queries").packages.x86_64-linux; oauth2MockServer = oauth2Flake.default; mkOauth2DB = oauth2Flake.mkOauth2DB; diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index e4dc20433..a184d7ddd 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -70,27 +70,27 @@ oauth2MockServer port = ---- User Queries ---- ---------------------- -data UserData = UD +data UserData = UD deriving (Show) instance FromJSON UserData where parseJSON _ = pure UD -queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m) +queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m) => Text -> Text - -> m (Either JSONException UserData) + -> m (Either JSONException Value) queryOAuth2User authPlugin userID = do (queryUrl, tokenUrl) <- liftIO $ mkBaseUrls authPlugin req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID mTokens <- lookupSessionJson SessionOAuth2Token - unless (isJust mTokens) . fail $ "Tried to load sesion Oauth2 tokens, but there are none" + unless (isJust mTokens) . liftIO . fail $ "Tried to load sesion Oauth2 tokens, but there are none" eNewToken <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl (authPlugin == azurePluginName) case eNewToken of Left e -> return $ Left e Right newTokens -> do - setSessionJson SessionOAuth2Token newTokens - getResponseBody <$> httpJSONEither @m @UserData (req + setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens) + getResponseBody <$> httpJSONEither @m @Value (req { secure = authPlugin == azurePluginName - , requestHeaders = [("Authorization", encodeUtf8 . atoken . fromJust $ fst newTokens)] }) + , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] }) mkBaseUrls :: Text -> IO (String, String) mkBaseUrls authPlugin @@ -106,26 +106,28 @@ mkBaseUrls authPlugin | otherwise = fail $ "Unsupported auth plugin: " ++ unpack authPlugin -refreshOAuth2Token :: forall m x. (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m, x ~ (Maybe AccessToken, Maybe RefreshToken)) - => x +refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m) + => (Maybe AccessToken, Maybe RefreshToken) -> String -> Bool - -> m (Either JSONException x) -refreshOAuth2Token (_, refreshToken) url secure - | isJust refreshToken = do + -> m (Either JSONException OAuth2Token) +refreshOAuth2Token (_, rToken) url secure + | isJust rToken = do req <- parseRequest $ "POST " ++ url let body = [ ("grant_type", "refresh_token") - , ("refresh_token", encodeUtf8 . rtoken $ fromJust refreshToken) - , ("scope", "") -- TODO must be subset of previously requested scopes. space separated list + , ("refresh_token", encodeUtf8 . rtoken $ fromJust rToken) ] body' <- if secure then do - Just clientID <- liftIO $ lookupEnv "CLIENT_ID" - Just clientSecret <- liftIO $ lookupEnv "CLIENT_SECRET" - return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret)] - else return body - getResponseBody <$> httpJSONEither @m @x (urlEncodedBody body' req{ secure = secure }) - | otherwise = fail "Could not refresh access token. Refresh token is missing." - + clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID" + clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET" + return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")] + else return $ ("scope", "ID Profile") : body + $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure }) + getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) + | otherwise = liftIO $ fail "Could not refresh access token. Refresh token is missing." +instance Show RequestBody where + show (RequestBodyLBS x) = show x + show _ = error ":(" diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs index fdd8b8f63..997a61756 100644 --- a/src/Handler/Admin/OAuth2.hs +++ b/src/Handler/Admin/OAuth2.hs @@ -1,9 +1,9 @@ --- SPDX-FileCopyrightText: 2023 Sarah Vaupel ,David Mosbach +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Admin.OAuth2 - ( getAdminOAuth2R + ( getAdminOAuth2R , postAdminOAuth2R ) where @@ -15,6 +15,12 @@ import Data.Text() --import Foundation.Yesod.Auth (CampusUserConversionException()) import Handler.Utils +# ifdef DEVELOPMENT +import Auth.OAuth2 (queryOAuth2User, mockPluginName) +# else +import Auth.OAuth2 (queryOAuth2User, azurePluginName) +# endif + getAdminOAuth2R, postAdminOAuth2R :: Handler Html getAdminOAuth2R = postAdminOAuth2R @@ -23,8 +29,14 @@ postAdminOAuth2R = do flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing let procFormPerson :: Text -> Handler (Maybe Text) - procFormPerson lid = return . Just $ "Mock reply for id " <> lid - -- TODO implement oauth query + procFormPerson lid = do --return . Just $ "Mock reply for id " <> lid +# ifdef DEVELOPMENT + let authPlugin = mockPluginName +# else + let authPlugin = azurePluginName +# endif + eUserData <- queryOAuth2User authPlugin lid + return . Just $ tshow eUserData mOAuth2Data <- formResultMaybe presult procFormPerson --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> From 1d7b46b4a4ba37343cd6fce26577830b50fb6297 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 1 Feb 2024 12:20:47 +0100 Subject: [PATCH 058/178] chore(npm): remove oauth2-mock-server --- package-lock.json | 302 ---------------------------------------------- package.json | 1 - 2 files changed, 303 deletions(-) diff --git a/package-lock.json b/package-lock.json index 20db09f4d..fb4545bc0 100644 --- a/package-lock.json +++ b/package-lock.json @@ -2404,12 +2404,6 @@ "integrity": "sha512-8+9WqebbFzpX9OR+Wa6O29asIogeRMzcGtAINdpMHHyAg10f05aSFVBbcEqGf/PXw1EjAZ+q2/bEBg3DvurK3Q==", "dev": true }, - "array-flatten": { - "version": "1.1.1", - "resolved": "https://registry.npmjs.org/array-flatten/-/array-flatten-1.1.1.tgz", - "integrity": "sha512-PCVAQswWemu6UdxsDFFX/+gVeYqKAod3D3UVm91jHwynguOwAvYPhx8nNlM++NqRcK6CxxpUafjmhIdKiHibqg==", - "dev": true - }, "array-ify": { "version": "1.0.0", "resolved": "https://registry.npmjs.org/array-ify/-/array-ify-1.0.0.tgz", @@ -3525,23 +3519,6 @@ "integrity": "sha512-lGe34o6EHj9y3Kts9R4ZYs/Gr+6N7MCaMlIFA3F1R2O5/m7K06AxfSeO5530PEERE6/WyEg3lsuyw4GHlPZHog==", "dev": true }, - "basic-auth": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/basic-auth/-/basic-auth-2.0.1.tgz", - "integrity": "sha512-NF+epuEdnUYVlGuhaxbbq+dvJttwLnGY+YixlXlME5KpQ5W3CnXA5cVTneY3SPbPDRkcjMbifrwmFYcClgOZeg==", - "dev": true, - "requires": { - "safe-buffer": "5.1.2" - }, - "dependencies": { - "safe-buffer": { - "version": "5.1.2", - "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.1.2.tgz", - "integrity": "sha512-Gd2UZBJDkXlY7GbJxfsE8/nvKkUEU1G38c1siN6QP6a9PT9MmHB8GnpscSmMJSoF8LOIrt8ud/wPtojys4G6+g==", - "dev": true - } - } - }, "bcrypt-pbkdf": { "version": "1.0.2", "resolved": "https://registry.npmjs.org/bcrypt-pbkdf/-/bcrypt-pbkdf-1.0.2.tgz", @@ -4165,15 +4142,6 @@ } } }, - "content-disposition": { - "version": "0.5.4", - "resolved": "https://registry.npmjs.org/content-disposition/-/content-disposition-0.5.4.tgz", - "integrity": "sha512-FveZTNuGw04cxlAiWbzi6zTAL/lhehaWbTtgluJh4/E95DqMwTmha3KZN1aAWA8cFIhHzMZUvLevkw5Rqk+tSQ==", - "dev": true, - "requires": { - "safe-buffer": "5.2.1" - } - }, "content-type": { "version": "1.0.4", "resolved": "https://registry.npmjs.org/content-type/-/content-type-1.0.4.tgz", @@ -4549,12 +4517,6 @@ "integrity": "sha512-aSWTXFzaKWkvHO1Ny/s+ePFpvKsPnjc551iI41v3ny/ow6tBG5Vd+FuqGNhh1LxOmVzOlGUriIlOaokOvhaStA==", "dev": true }, - "cookie-signature": { - "version": "1.0.6", - "resolved": "https://registry.npmjs.org/cookie-signature/-/cookie-signature-1.0.6.tgz", - "integrity": "sha512-QADzlaHc8icV8I7vbaJXJwod9HWYp8uCqf1xa4OfNu1T7JVxQIrUgOWtHdNDtPiywmFbiS12VjotIXLrKM3orQ==", - "dev": true - }, "copy-webpack-plugin": { "version": "11.0.0", "resolved": "https://registry.npmjs.org/copy-webpack-plugin/-/copy-webpack-plugin-11.0.0.tgz", @@ -5074,12 +5036,6 @@ "integrity": "sha1-3zrhmayt+31ECqrgsp4icrJOxhk=", "dev": true }, - "depd": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/depd/-/depd-2.0.0.tgz", - "integrity": "sha512-g7nH6P6dyDioJogAAGprGpCtVImJhpPk/roCzdb3fIh61/s/nPsfR6onyMwkCAR/OlC3yBC0lESvUoQEAssIrw==", - "dev": true - }, "destroy": { "version": "1.2.0", "resolved": "https://registry.npmjs.org/destroy/-/destroy-1.2.0.tgz", @@ -5673,12 +5629,6 @@ "integrity": "sha512-kVscqXk4OCp68SZ0dkgEKVi6/8ij300KBWTJq32P/dYeWTSwK41WyTxalN1eRmA5Z9UU/LX9D7FWSmV9SAYx6g==", "dev": true }, - "etag": { - "version": "1.8.1", - "resolved": "https://registry.npmjs.org/etag/-/etag-1.8.1.tgz", - "integrity": "sha512-aIL5Fx7mawVa300al2BnEE4iNvo1qETxLrPI/o05L7z6go7fCw1J6EQmbK4FmJ2AS7kgVF/KEZWufBfdClMcPg==", - "dev": true - }, "eventemitter3": { "version": "4.0.7", "resolved": "https://registry.npmjs.org/eventemitter3/-/eventemitter3-4.0.7.tgz", @@ -5716,112 +5666,6 @@ } } }, - "express": { - "version": "4.18.2", - "resolved": "https://registry.npmjs.org/express/-/express-4.18.2.tgz", - "integrity": "sha512-5/PsL6iGPdfQ/lKM1UuielYgv3BUoJfz1aUwU9vHZ+J7gyvwdQXFEBIEIaxeGf0GIcreATNyBExtalisDbuMqQ==", - "dev": true, - "requires": { - "accepts": "~1.3.8", - "array-flatten": "1.1.1", - "body-parser": "1.20.1", - "content-disposition": "0.5.4", - "content-type": "~1.0.4", - "cookie": "0.5.0", - "cookie-signature": "1.0.6", - "debug": "2.6.9", - "depd": "2.0.0", - "encodeurl": "~1.0.2", - "escape-html": "~1.0.3", - "etag": "~1.8.1", - "finalhandler": "1.2.0", - "fresh": "0.5.2", - "http-errors": "2.0.0", - "merge-descriptors": "1.0.1", - "methods": "~1.1.2", - "on-finished": "2.4.1", - "parseurl": "~1.3.3", - "path-to-regexp": "0.1.7", - "proxy-addr": "~2.0.7", - "qs": "6.11.0", - "range-parser": "~1.2.1", - "safe-buffer": "5.2.1", - "send": "0.18.0", - "serve-static": "1.15.0", - "setprototypeof": "1.2.0", - "statuses": "2.0.1", - "type-is": "~1.6.18", - "utils-merge": "1.0.1", - "vary": "~1.1.2" - }, - "dependencies": { - "body-parser": { - "version": "1.20.1", - "resolved": "https://registry.npmjs.org/body-parser/-/body-parser-1.20.1.tgz", - "integrity": "sha512-jWi7abTbYwajOytWCQc37VulmWiRae5RyTpaCyDcS5/lMdtwSz5lOpDE67srw/HYe35f1z3fDQw+3txg7gNtWw==", - "dev": true, - "requires": { - "bytes": "3.1.2", - "content-type": "~1.0.4", - "debug": "2.6.9", - "depd": "2.0.0", - "destroy": "1.2.0", - "http-errors": "2.0.0", - "iconv-lite": "0.4.24", - "on-finished": "2.4.1", - "qs": "6.11.0", - "raw-body": "2.5.1", - "type-is": "~1.6.18", - "unpipe": "1.0.0" - } - }, - "cookie": { - "version": "0.5.0", - "resolved": "https://registry.npmjs.org/cookie/-/cookie-0.5.0.tgz", - "integrity": "sha512-YZ3GUyn/o8gfKJlnlX7g7xq4gyO6OSuhGPKaaGssGB2qgDUS0gPgtTvoyZLTt9Ab6dC4hfc9dV5arkvc/OCmrw==", - "dev": true - }, - "debug": { - "version": "2.6.9", - "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz", - "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==", - "dev": true, - "requires": { - "ms": "2.0.0" - } - }, - "finalhandler": { - "version": "1.2.0", - "resolved": "https://registry.npmjs.org/finalhandler/-/finalhandler-1.2.0.tgz", - "integrity": "sha512-5uXcUVftlQMFnWC9qu/svkWv3GTd2PfUhK/3PLkYNAe7FbqJMt3515HaxE6eRL74GdsriiwujiawdaB1BpEISg==", - "dev": true, - "requires": { - "debug": "2.6.9", - "encodeurl": "~1.0.2", - "escape-html": "~1.0.3", - "on-finished": "2.4.1", - "parseurl": "~1.3.3", - "statuses": "2.0.1", - "unpipe": "~1.0.0" - } - }, - "ms": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz", - "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==", - "dev": true - }, - "qs": { - "version": "6.11.0", - "resolved": "https://registry.npmjs.org/qs/-/qs-6.11.0.tgz", - "integrity": "sha512-MvjoMCJwEarSbUYk5O+nmoSzSutSsTwF85zcHPQ9OrlFoZOYIjaqBAJIqIXjptyD5vThxGq52Xu/MaJzRkIk4Q==", - "dev": true, - "requires": { - "side-channel": "^1.0.4" - } - } - } - }, "extend": { "version": "3.0.2", "resolved": "https://registry.npmjs.org/extend/-/extend-3.0.2.tgz", @@ -6037,24 +5881,12 @@ "mime-types": "^2.1.12" } }, - "forwarded": { - "version": "0.2.0", - "resolved": "https://registry.npmjs.org/forwarded/-/forwarded-0.2.0.tgz", - "integrity": "sha512-buRG0fpBtRHSTCOASe6hD258tEubFoRLb4ZNA6NxMVHNw2gOcwHo9wyablzMzOA5z9xA9L1KNjk/Nt6MT9aYow==", - "dev": true - }, "fraction.js": { "version": "4.2.0", "resolved": "https://registry.npmjs.org/fraction.js/-/fraction.js-4.2.0.tgz", "integrity": "sha512-MhLuK+2gUcnZe8ZHlaaINnQLl0xRIGRfcGk2yl8xoQAfHrSsL3rYu6FCmBdkdbhc9EPlwyGHewaRsvwRMJtAlA==", "dev": true }, - "fresh": { - "version": "0.5.2", - "resolved": "https://registry.npmjs.org/fresh/-/fresh-0.5.2.tgz", - "integrity": "sha512-zJ2mQYM18rEFOudeV4GShTGIQ7RbzA7ozbU9I/XBpm7kqgMywgmylMwXHxZJmkVoYkna9d2pVXVXPdYTP9ej8Q==", - "dev": true - }, "fs-extra": { "version": "10.1.0", "resolved": "https://registry.npmjs.org/fs-extra/-/fs-extra-10.1.0.tgz", @@ -6609,15 +6441,6 @@ "integrity": "sha512-xs7/chUH/CKdOCs7Zy0Aev9e/dKOMZf3K1Az1nar3tzlv0jfqnYtu235bstsWTmXOR0EfINrPa97yy4Lz6RiKw==", "dev": true }, - "iconv-lite": { - "version": "0.4.24", - "resolved": "https://registry.npmjs.org/iconv-lite/-/iconv-lite-0.4.24.tgz", - "integrity": "sha512-v3MXnZAcvnywkTUEZomIActle7RXXeedOR31wwl7VlyoXO4Qi9arvSenNQWne1TcRwhCL1HwLI21bEqdpj8/rA==", - "dev": true, - "requires": { - "safer-buffer": ">= 2.1.2 < 3" - } - }, "icss-utils": { "version": "5.1.0", "resolved": "https://registry.npmjs.org/icss-utils/-/icss-utils-5.1.0.tgz", @@ -6718,12 +6541,6 @@ "loose-envify": "^1.0.0" } }, - "ipaddr.js": { - "version": "1.9.1", - "resolved": "https://registry.npmjs.org/ipaddr.js/-/ipaddr.js-1.9.1.tgz", - "integrity": "sha512-0KI/607xoxSToH7GjN1FfSbLoU0+btTicjsQSWQlh/hZykN8KpmMf7uYwPW3R+akZ6R/w18ZlXSHBYXiYUPO3g==", - "dev": true - }, "is-arrayish": { "version": "0.2.1", "resolved": "https://registry.npmjs.org/is-arrayish/-/is-arrayish-0.2.1.tgz", @@ -7008,12 +6825,6 @@ } } }, - "jose": { - "version": "4.15.4", - "resolved": "https://registry.npmjs.org/jose/-/jose-4.15.4.tgz", - "integrity": "sha512-W+oqK4H+r5sITxfxpSU+MMdr/YSWGvgZMQDIsNoBDGGy4i7GBPTtvFKibQzW06n3U3TqHjhvBJsirShsEJ6eeQ==", - "dev": true - }, "js-cookie": { "version": "3.0.1", "resolved": "https://registry.npmjs.org/js-cookie/-/js-cookie-3.0.1.tgz", @@ -8011,12 +7822,6 @@ } } }, - "merge-descriptors": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/merge-descriptors/-/merge-descriptors-1.0.1.tgz", - "integrity": "sha512-cCi6g3/Zr1iqQi6ySbseM1Xvooa98N0w31jzUYrXPX2xqObmFGHJ0tQ5u74H3mVh7wLouTseZyYIq39g8cNp1w==", - "dev": true - }, "merge-stream": { "version": "2.0.0", "resolved": "https://registry.npmjs.org/merge-stream/-/merge-stream-2.0.0.tgz", @@ -8041,12 +7846,6 @@ "underscore": "*" } }, - "methods": { - "version": "1.1.2", - "resolved": "https://registry.npmjs.org/methods/-/methods-1.1.2.tgz", - "integrity": "sha512-iclAHeNqNm68zFtnZ0e+1L2yUIdvzNoauKU4WBA3VvH/vPFieF7qfRlwUZU+DA9P9bPXIS90ulxoUoCH23sV2w==", - "dev": true - }, "micromatch": { "version": "4.0.5", "resolved": "https://registry.npmjs.org/micromatch/-/micromatch-4.0.5.tgz", @@ -10055,27 +9854,6 @@ } } }, - "oauth2-mock-server": { - "version": "7.1.1", - "resolved": "https://registry.npmjs.org/oauth2-mock-server/-/oauth2-mock-server-7.1.1.tgz", - "integrity": "sha512-4/PdPZLySsC68IoiO79BKpr5Rv2j2+WgFZskox7bzSlsXqoX8Nm9OWm3IXB0HQ7xJCbzcR4vvvcDe6UnA/UIiw==", - "dev": true, - "requires": { - "basic-auth": "^2.0.1", - "cors": "^2.8.5", - "express": "^4.18.2", - "is-plain-object": "^5.0.0", - "jose": "^4.15.4" - }, - "dependencies": { - "is-plain-object": { - "version": "5.0.0", - "resolved": "https://registry.npmjs.org/is-plain-object/-/is-plain-object-5.0.0.tgz", - "integrity": "sha512-VRSzKkbMm5jMDoKLbltAkFQ5Qr7VDiTFGXxYFXXowVj387GeGNOCsOH6Msy00SGZ3Fp84b1Naa1psqgcCIEP5Q==", - "dev": true - } - } - }, "object-assign": { "version": "4.1.1", "resolved": "https://registry.npmjs.org/object-assign/-/object-assign-4.1.1.tgz", @@ -10286,12 +10064,6 @@ "integrity": "sha512-LDJzPVEEEPR+y48z93A0Ed0yXb8pAByGWo/k5YYdYgpY2/2EsOsksJrq7lOHxryrVOn1ejG6oAp8ahvOIQD8sw==", "dev": true }, - "path-to-regexp": { - "version": "0.1.7", - "resolved": "https://registry.npmjs.org/path-to-regexp/-/path-to-regexp-0.1.7.tgz", - "integrity": "sha512-5DFkuoqlv1uYQKxy8omFBeJPQcdoE07Kv2sferDCrAq1ohOU+MSDswDIbnx3YAM60qIOnYa53wBhXW0EbMonrQ==", - "dev": true - }, "path-type": { "version": "4.0.0", "resolved": "https://registry.npmjs.org/path-type/-/path-type-4.0.0.tgz", @@ -11046,16 +10818,6 @@ "integrity": "sha512-3ouUOpQhtgrbOa17J7+uxOTpITYWaGP7/AhoR3+A+/1e9skrzelGi/dXzEYyvbxubEF6Wn2ypscTKiKJFFn1ag==", "dev": true }, - "proxy-addr": { - "version": "2.0.7", - "resolved": "https://registry.npmjs.org/proxy-addr/-/proxy-addr-2.0.7.tgz", - "integrity": "sha512-llQsMLSUDUPT44jdrU/O37qlnifitDP+ZwrmmZcoSKyLKvtZxpyV0n2/bD/N4tBAAZ/gJEdZU7KMraoK1+XYAg==", - "dev": true, - "requires": { - "forwarded": "0.2.0", - "ipaddr.js": "1.9.1" - } - }, "psl": { "version": "1.8.0", "resolved": "https://registry.npmjs.org/psl/-/psl-1.8.0.tgz", @@ -11795,58 +11557,6 @@ } } }, - "send": { - "version": "0.18.0", - "resolved": "https://registry.npmjs.org/send/-/send-0.18.0.tgz", - "integrity": "sha512-qqWzuOjSFOuqPjFe4NOsMLafToQQwBSOEpS+FwEt3A2V3vKubTquT3vmLTQpFgMXp8AlFWFuP1qKaJZOtPpVXg==", - "dev": true, - "requires": { - "debug": "2.6.9", - "depd": "2.0.0", - "destroy": "1.2.0", - "encodeurl": "~1.0.2", - "escape-html": "~1.0.3", - "etag": "~1.8.1", - "fresh": "0.5.2", - "http-errors": "2.0.0", - "mime": "1.6.0", - "ms": "2.1.3", - "on-finished": "2.4.1", - "range-parser": "~1.2.1", - "statuses": "2.0.1" - }, - "dependencies": { - "debug": { - "version": "2.6.9", - "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz", - "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==", - "dev": true, - "requires": { - "ms": "2.0.0" - }, - "dependencies": { - "ms": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz", - "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==", - "dev": true - } - } - }, - "mime": { - "version": "1.6.0", - "resolved": "https://registry.npmjs.org/mime/-/mime-1.6.0.tgz", - "integrity": "sha512-x0Vn8spI+wuJ1O6S7gnbaQg8Pxh4NNHb7KSINmEWKiPE4RKOplvijn+NkmYmmRgP68mc70j2EbeTFRsrswaQeg==", - "dev": true - }, - "ms": { - "version": "2.1.3", - "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.3.tgz", - "integrity": "sha512-6FlzubTLZG3J2a/NVCAleEhjzq5oxgHyaCU9yYXvcLsvoVaHJq/s5xXI6/XXP6tz7R9xAOtHnSO/tXtF3WRTlA==", - "dev": true - } - } - }, "serialize-javascript": { "version": "6.0.0", "resolved": "https://registry.npmjs.org/serialize-javascript/-/serialize-javascript-6.0.0.tgz", @@ -11856,18 +11566,6 @@ "randombytes": "^2.1.0" } }, - "serve-static": { - "version": "1.15.0", - "resolved": "https://registry.npmjs.org/serve-static/-/serve-static-1.15.0.tgz", - "integrity": "sha512-XGuRDNjXUijsUL0vl6nSD7cwURuzEgglbOaFuZM9g3kwDXOWVTck0jLzjPzGD+TazWbboZYu52/9/XPdUgne9g==", - "dev": true, - "requires": { - "encodeurl": "~1.0.2", - "escape-html": "~1.0.3", - "parseurl": "~1.3.3", - "send": "0.18.0" - } - }, "setimmediate": { "version": "1.0.5", "resolved": "https://registry.npmjs.org/setimmediate/-/setimmediate-1.0.5.tgz", diff --git a/package.json b/package.json index d9c34b4d6..25437a405 100644 --- a/package.json +++ b/package.json @@ -86,7 +86,6 @@ "mini-css-extract-plugin": "^2.6.0", "npm-run-all": "^4.1.5", "null-loader": "^4.0.1", - "oauth2-mock-server": "^7.1.1", "optimize-css-assets-webpack-plugin": "^6.0.1", "postcss-loader": "^7.0.0", "postcss-preset-env": "^7.7.1", From a85a5be4cd78b4a198bcc877a73f3ab21eda340f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 1 Feb 2024 20:51:31 +0100 Subject: [PATCH 059/178] chore(auth): mockPluginName->apAzureMock --- src/Auth/OAuth2.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index f30f4d7c1..2d340baa3 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -9,8 +9,8 @@ module Auth.OAuth2 , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage , azureUser, azureUser' , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous + , apAzureMock , oauth2MockServer - , mockPluginName ) where import qualified Data.CaseInsensitive as CI @@ -79,8 +79,8 @@ azureUser' conf User{userIdent} ---- OAuth2 development auth plugin ---- ---------------------------------------- -mockPluginName :: Text -mockPluginName = "uniworx_dev" +apAzureMock :: Text +apAzureMock = "uniworx_dev" newtype UserID = UserID Text instance FromJSON UserID where @@ -98,10 +98,10 @@ oauth2MockServer = } mockServerURL = "0.0.0.0/" profileSrc = fromString $ mockServerURL <> "/foo" - in authOAuth2 mockPluginName oa $ \manager token -> do - (UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc + in authOAuth2 apAzureMock oa $ \manager token -> do + (UserID userID, userResponse) <- authGetProfile apAzureMock manager token profileSrc return Creds - { credsPlugin = mockPluginName + { credsPlugin = apAzureMock , credsIdent = userID , credsExtra = setExtra token userResponse } From ac045fdc70a8dccdb6cb0a08321d1bc69d0ebc68 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 1 Feb 2024 20:53:55 +0100 Subject: [PATCH 060/178] chore(auth): oauth2MockServer->azureMockServer --- src/Application.hs | 2 +- src/Auth/OAuth2.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index cac5ce2c1..5a513c825 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -356,7 +356,7 @@ makeFoundation appSettings''@AppSettings{..} = do return . uncurry p $ fromJust mArgs appAuthPlugins <- liftIO $ sequence [ - return oauth2MockServer + return azureMockServer , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2" ] diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 2d340baa3..3bec397b0 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -10,7 +10,7 @@ module Auth.OAuth2 , azureUser, azureUser' , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous , apAzureMock - , oauth2MockServer + , azureMockServer ) where import qualified Data.CaseInsensitive as CI @@ -87,8 +87,8 @@ instance FromJSON UserID where parseJSON = withObject "UserID" $ \o -> UserID <$> o .: "id" -oauth2MockServer :: YesodAuth m => AuthPlugin m -oauth2MockServer = +azureMockServer :: YesodAuth m => AuthPlugin m +azureMockServer = let oa = OAuth2 { oauth2ClientId = "uniworx" , oauth2ClientSecret = Just "shh" From d4cfce317d00714404ea3640cae8ad25182594b0 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sat, 3 Feb 2024 20:48:32 +0000 Subject: [PATCH 061/178] feat(auth): formatted output of user queries --- src/Auth/OAuth2.hs | 75 +++++++++++++++++++++--------------- src/Foundation/Yesod/Auth.hs | 4 ++ src/Handler/Admin/OAuth2.hs | 24 +++++------- templates/oauth2.hamlet | 3 +- 4 files changed, 58 insertions(+), 48 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index a184d7ddd..fab04ca16 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -10,6 +10,7 @@ module Auth.OAuth2 , oauth2MockServer , mockPluginName , queryOAuth2User +, UserDataException ) where import Data.Maybe (fromJust) @@ -70,47 +71,54 @@ oauth2MockServer port = ---- User Queries ---- ---------------------- -data UserData = UD deriving (Show) -instance FromJSON UserData where - parseJSON _ = pure UD +data UserDataException = UserDataJSONException JSONException + | UserDataInternalException Text + deriving Show -queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m) +instance Exception UserDataException + +queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m) => Text - -> Text - -> m (Either JSONException Value) -queryOAuth2User authPlugin userID = do - (queryUrl, tokenUrl) <- liftIO $ mkBaseUrls authPlugin + -> m (Either UserDataException j) +queryOAuth2User userID = runExceptT $ do + (queryUrl, tokenUrl) <- liftIO mkBaseUrls req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID mTokens <- lookupSessionJson SessionOAuth2Token - unless (isJust mTokens) . liftIO . fail $ "Tried to load sesion Oauth2 tokens, but there are none" - eNewToken <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl (authPlugin == azurePluginName) - case eNewToken of - Left e -> return $ Left e - Right newTokens -> do - setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens) - getResponseBody <$> httpJSONEither @m @Value (req - { secure = authPlugin == azurePluginName - , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] }) + unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none" +# ifdef DEVELOPMENT + let secure = False +# else + let secure = True +# endif + newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure + setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens) + eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req + { secure = secure + , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x -mkBaseUrls :: Text -> IO (String, String) -mkBaseUrls authPlugin - | authPlugin == azurePluginName = do - Just tenantID <- lookupEnv "AZURE_TENANT_ID" - return ( "https://graph.microsoft.com/v1.0/users/" - , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) - | authPlugin == mockPluginName = do - Just port <- lookupEnv "OAUTH2_SERVER_PORT" - let base = "http://localhost:" ++ port - return ( base ++ "/users/query?id=" - , base ++ "/token" ) - | otherwise = fail $ "Unsupported auth plugin: " ++ unpack authPlugin + +mkBaseUrls :: IO (String, String) +mkBaseUrls = do +# ifndef DEVELOPMENT + Just tenantID <- lookupEnv "AZURE_TENANT_ID" + return ( "https://graph.microsoft.com/v1.0/users/" + , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) +# else + Just port <- lookupEnv "OAUTH2_SERVER_PORT" + let base = "http://localhost:" ++ port + return ( base ++ "/users/query?id=" + , base ++ "/token" ) +# endif refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m) => (Maybe AccessToken, Maybe RefreshToken) -> String -> Bool - -> m (Either JSONException OAuth2Token) + -> ExceptT UserDataException m OAuth2Token refreshOAuth2Token (_, rToken) url secure | isJust rToken = do req <- parseRequest $ "POST " ++ url @@ -125,8 +133,11 @@ refreshOAuth2Token (_, rToken) url secure return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")] else return $ ("scope", "ID Profile") : body $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure }) - getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) - | otherwise = liftIO $ fail "Could not refresh access token. Refresh token is missing." + eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x + | otherwise = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing." instance Show RequestBody where show (RequestBodyLBS x) = show x diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 2bd046479..7c3594a53 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -24,6 +24,7 @@ import Handler.Utils.Memcached import Foundation.Authorization (AuthorizationCacheKey(..)) import Yesod.Auth.Message +import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken) import Auth.LDAP import Auth.OAuth2 import Auth.PWHash (apHash) @@ -131,6 +132,9 @@ oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX => Creds UniWorX -> m (AuthenticationResult UniWorX) oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds) + sess <- getSession + $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m" now <- liftIO getCurrentTime let diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs index 997a61756..1face989f 100644 --- a/src/Handler/Admin/OAuth2.hs +++ b/src/Handler/Admin/OAuth2.hs @@ -9,17 +9,14 @@ module Handler.Admin.OAuth2 import Import -- import qualified Data.CaseInsensitive as CI -import Data.Text() ---import qualified Data.Text as Text +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T --import qualified Data.Text.Encoding as Text --import Foundation.Yesod.Auth (CampusUserConversionException()) import Handler.Utils -# ifdef DEVELOPMENT -import Auth.OAuth2 (queryOAuth2User, mockPluginName) -# else -import Auth.OAuth2 (queryOAuth2User, azurePluginName) -# endif +import Auth.OAuth2 (queryOAuth2User) getAdminOAuth2R, postAdminOAuth2R :: Handler Html @@ -28,15 +25,12 @@ postAdminOAuth2R = do ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing - let procFormPerson :: Text -> Handler (Maybe Text) + let procFormPerson :: Text -> Handler (Maybe T.Text) procFormPerson lid = do --return . Just $ "Mock reply for id " <> lid -# ifdef DEVELOPMENT - let authPlugin = mockPluginName -# else - let authPlugin = azurePluginName -# endif - eUserData <- queryOAuth2User authPlugin lid - return . Just $ tshow eUserData + eUserData <- queryOAuth2User @Value lid + case eUserData of + Left e -> throwM e + Right userData -> return . Just . T.decodeUtf8 $ encodePretty userData mOAuth2Data <- formResultMaybe presult procFormPerson --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> diff --git a/templates/oauth2.hamlet b/templates/oauth2.hamlet index 23030ebd6..90711a799 100644 --- a/templates/oauth2.hamlet +++ b/templates/oauth2.hamlet @@ -13,6 +13,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Antwort: #
- #{show answers} + 
+              #{answers}
           

             

From fafa25a7b51b734e5172fc3b80295b418e663535 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Sat, 3 Feb 2024 21:10:24 +0000
Subject: [PATCH 062/178] chore(auth): auto start oauth2 mock server in develop

---
 shell.nix | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/shell.nix b/shell.nix
index 4b114f966..c02c51c19 100644
--- a/shell.nix
+++ b/shell.nix
@@ -62,6 +62,7 @@ let
       type cleanup_minio &>/dev/null && cleanup_minio
       type cleanup_maildev &>/dev/null && cleanup_maildev
       [[ -z "$OAUTH2_PGDIR" ]] || source ${killOauth2DB}/bin/killOauth2DB
+      [[ -z "$OAUTH2_PGHOST" ]] || pkill oauth2-mock-ser
 
       [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env"
       set +x
@@ -74,6 +75,7 @@ let
     if [[ -z "$OAUTH2_PGHOST" ]]; then
       set -xe
       source ${mkOauth2DB}/bin/mkOauth2DB
+      ${oauth2MockServer}/bin/oauth2-mock-server&
       set +xe
     fi
 
@@ -300,7 +302,7 @@ in pkgs.mkShell {
   OAUTH2_TEST_USERS = ./test/Database/test-users.yaml;
   OAUTH2_SERVER_PORT = 9443;
   OAUTH2_DB_PORT = 9444;
-  nativeBuildInputs = [develop inDevelop killallUni2work diffRunning oauth2MockServer]
+  nativeBuildInputs = [develop inDevelop killallUni2work diffRunning]
   ++ (with pkgs;
     [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client
       gup reuse pre-commit

From 12fe58fc81eada015103f6eff4a486fd6f03cbec Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 9 Feb 2024 18:17:43 +0100
Subject: [PATCH 063/178] chore(model)!: move user authentication data to new
 ExternalUser model

---
 models/users.model | 24 ++++++++++++++----------
 1 file changed, 14 insertions(+), 10 deletions(-)

diff --git a/models/users.model b/models/users.model
index fa4bdfce5..bba5b18a1 100644
--- a/models/users.model
+++ b/models/users.model
@@ -1,8 +1,8 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
--- The files in /models determine t he database scheme.
+-- The files in /models determine the database scheme.
 -- The organisational split into several files has no operational effects.
 -- White-space and case matters: Each SQL table is named in 1st column of this file
 -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
@@ -11,19 +11,16 @@
 -- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns.
 -- 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.
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
     email          UserEmail                -- Case-insensitive eMail address, used for sending  TODO: make this nullable
     ident          UserIdent                -- Case-insensitive user-identifier
-    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
+    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash) -- TODO: redo (add InternalUser table for password hash)
     lastAuthentication UTCTime Maybe        -- last login date
     created        UTCTime default=now()
-    lastLdapSynchronisation UTCTime Maybe
-    lastAzureSynchronisation UTCTime Maybe
-    ldapPrimaryKey UserEduPersonPrincipalName Maybe
-    azurePrimaryKey UUID Maybe
     tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null)
     matrikelnummer UserMatriculation Maybe  -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
     firstName      Text                     -- For export in tables, pre-split firstName from displayName
@@ -54,10 +51,18 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
     UniqueAuthentication ident                  -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
-    UniqueLdapPrimaryKey ldapPrimaryKey !force  -- Column 'ldapPrimaryKey' is either empty or contains a unique value
-    UniqueAzurePrimaryKey azurePrimaryKey !force  -- Column 'azurePrimaryKey' is either empty or contains a unique value
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
+-- User authentication data fetched from external sources
+ExternalUser
+    source            Text                 -- External source ID
+    ident             UserIdent            -- External user ID
+    data              Value "default='{}'::jsonb"  -- Raw user data from external source
+    lastSourceSync    UTCTime              -- When was the entry last synced with the external source?
+    lastUserSync      UTCTime Maybe        -- When was the corresponding User entry last synced with this entry? TODO: maybe move to User instead
+    UniqueExternalUser source ident
+    deriving Show Eq Ord Generic
+
 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
     user     UserId
     school   SchoolId
@@ -102,4 +107,3 @@ UserSupervisor
     rerouteNotifications  Bool   -- User can be his own supervisor to receive notifications as well
     UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
     deriving Generic
-    

From 3f5a22c85d6db947d6a77b34bff15d75f25d30f3 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Fri, 9 Feb 2024 17:38:35 +0000
Subject: [PATCH 064/178] chore(auth): update oauth2 mock server

---
 shell.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/shell.nix b/shell.nix
index c02c51c19..58494040a 100644
--- a/shell.nix
+++ b/shell.nix
@@ -9,7 +9,7 @@ let
 
   haskellPackages = pkgs.haskellPackages;
 
-  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=6fc2d621573e048b7ce2dabfc4887c7876055f8d&ref=user-queries").packages.x86_64-linux;
+  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=d47908b4f7883b4b485abf1ee06645495ccdc7b3&ref=user-queries").packages.x86_64-linux;
 
   oauth2MockServer = oauth2Flake.default;
   mkOauth2DB = oauth2Flake.mkOauth2DB;

From cc8bd19f85a509ee338f8a697ae880a8a1fc44c4 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 10 Feb 2024 00:27:36 +0100
Subject: [PATCH 065/178] refactor(ldap): CampusUserError -> LdapUserError

---
 src/Auth/LDAP.hs | 37 +++++++++++++++++++------------------
 1 file changed, 19 insertions(+), 18 deletions(-)

diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 8ad8c2aab..c8650bc44 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -8,7 +8,7 @@ module Auth.LDAP
   ( apLdap
   , ADError(..), ADInvalidCredentials(..)
   , ldapLogin
-  , CampusUserException(..)
+  , LdapUserException(..)
   , ldapUser, ldapUser', ldapUser''
 --, ldapUserReTest, ldapUserReTest'
   , ldapUserMatr, ldapUserMatr'
@@ -46,11 +46,13 @@ apLdap = "LDAP"
 deriving newtype instance Ord Ldap.Attr
 
 
+-- TODO: rename
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
   , campusPassword :: Text
   } deriving (Generic)
 
+-- TODO: rename
 data CampusMessage = MsgCampusIdentPlaceholder
                    | MsgCampusIdent
                    | MsgCampusPassword
@@ -118,15 +120,14 @@ ldapUserEmail = Ldap.Attr "mail" :|
   ]
 
 
--- TODO: rename
-data CampusUserException = CampusUserLdapError LdapPoolError
-                         | CampusUserNoResult
-                         | CampusUserAmbiguous
+data LdapUserException = LdapUserLdapError LdapPoolError
+                       | LdapUserNoResult
+                       | LdapUserAmbiguous
   deriving (Show, Eq, Generic)
 
-instance Exception CampusUserException
+instance Exception LdapUserException
 
-makePrisms ''CampusUserException
+makePrisms ''LdapUserException
 
 
 ldapUserWith :: ( MonadUnliftIO m
@@ -139,13 +140,13 @@ ldapUserWith :: ( MonadUnliftIO m
                 --     -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
                 -- )
              => (    LdapPool
-                  -> (Ldap -> m (Either CampusUserException (Ldap.AttrList [])))
-                  -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
+                  -> (Ldap -> m (Either LdapUserException (Ldap.AttrList [])))
+                  -> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList [])))
                 )
              -> (LdapConf, LdapPool)
              -> Creds site
-             -> m (Either CampusUserException (Ldap.AttrList []))
-ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
+             -> m (Either LdapUserException (Ldap.AttrList []))
+ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
   lift $ Ldap.bind ldap ldapDn ldapPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do
@@ -154,9 +155,9 @@ ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . Ca
     Nothing -> do
       lift $ findUser conf ldap credsIdent []
   case results of
-    [] -> throwE CampusUserNoResult
+    [] -> throwE LdapUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwE CampusUserAmbiguous
+    _otherwise -> throwE LdapUserAmbiguous
 
 
 -- TODO: reintroduce once failover has been reimplemented
@@ -212,7 +213,7 @@ ldapUser'' :: ( MonadMask m
            -> Text
            -> m (Maybe (Ldap.AttrList []))
 ldapUser'' pool ident
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool (Creds apLdap ident [])
+  = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) $ ldapUser pool (Creds apLdap ident [])
 
 
 ldapUserMatr :: ( MonadUnliftIO m
@@ -222,13 +223,13 @@ ldapUserMatr :: ( MonadUnliftIO m
              => (LdapConf, LdapPool)
              -> UserMatriculation
              -> m (Ldap.AttrList [])
-ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
+ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
   Ldap.bind ldap ldapDn ldapPassword
   results <- findUserMatr conf ldap userMatr []
   case results of
-    [] -> throwM CampusUserNoResult
+    [] -> throwM LdapUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwM CampusUserAmbiguous
+    _otherwise -> throwM LdapUserAmbiguous
 
 ldapUserMatr' :: ( MonadMask m
                  , MonadUnliftIO m
@@ -237,7 +238,7 @@ ldapUserMatr' :: ( MonadMask m
               => (LdapConf, LdapPool)
               -> UserMatriculation
               -> m (Maybe (Ldap.AttrList []))
-ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool
+ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) . ldapUserMatr pool
 
 
 newtype ADInvalidCredentials = ADInvalidCredentials ADError

From 223ae0f2f8256bd3b1bd73c574afcd88b7dfc471 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sat, 10 Feb 2024 16:34:37 +0100
Subject: [PATCH 066/178] refactor(messages): rename campus error messages

---
 .../categories/authorization/de-de-formal.msg | 20 +++++++++----------
 .../categories/authorization/en-eu.msg        | 20 +++++++++----------
 2 files changed, 20 insertions(+), 20 deletions(-)

diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg
index f9a26de23..026a6aa62 100644
--- a/messages/uniworx/categories/authorization/de-de-formal.msg
+++ b/messages/uniworx/categories/authorization/de-de-formal.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -102,15 +102,15 @@ LDAPLoginTitle: Fraport Login für interne und externe Nutzer
 PWHashLoginTitle: Spezieller Funktionsnutzer Login
 PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden!
 DummyLoginTitle: Development-Login
-InternalLdapError: Interner Fehler beim Fraport Büko-Login
-CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
-CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
-CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
-CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
-CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
-CampusUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
-CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
-CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
+InternalLoginError: Interner Fehler beim Login
+UserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
+UserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
+UserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
+UserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
+UserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
+UserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
+UserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
+UserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
 InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht
 InvalidCredentialsADLogonFailure: Ungültiges Passwort
 InvalidCredentialsADAccountRestriction: Beschränkungen des Fraport Accounts verhindern Login
diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg
index b539efbf1..bc76b9a6e 100644
--- a/messages/uniworx/categories/authorization/en-eu.msg
+++ b/messages/uniworx/categories/authorization/en-eu.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -103,15 +103,15 @@ LDAPLoginTitle: Fraport login for intern and extern users
 PWHashLoginTitle: Special function user login
 PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field.
 DummyLoginTitle: Development login
-InternalLdapError: Internal error during Fraport Büko login
-CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login
-CampusUserInvalidEmail: Could not determine email address during Fraport Büko login
-CampusUserInvalidDisplayName: Could not determine display name during Fraport Büko login
-CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login
-CampusUserInvalidSurname: Could not determine surname during Fraport Büko login
-CampusUserInvalidTitle: Could not determine title during Fraport Büko login
-CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
-CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
+InternalLoginError: Internal error during login
+UserInvalidIdent: Could not determine unique identification during Fraport Büko login
+UserInvalidEmail: Could not determine email address during Fraport Büko login
+UserInvalidDisplayName: Could not determine display name during Fraport Büko login
+UserInvalidGivenName: Could not determine given name during Fraport Büko login
+UserInvalidSurname: Could not determine surname during Fraport Büko login
+UserInvalidTitle: Could not determine title during Fraport Büko login
+UserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
+UserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
 InvalidCredentialsADNoSuchObject: User entry does not exist
 InvalidCredentialsADLogonFailure: Invalid password
 InvalidCredentialsADAccountRestriction: Restrictions on your Fraport account prevent a login

From 2e47df00b9b24e7c4186279062e5059126856eca Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 11 Feb 2024 01:44:18 +0100
Subject: [PATCH 067/178] refactor(model): rename module Model.Types.Security
 -> Model.Types.Auth

---
 src/Model/Types.hs                       | 2 +-
 src/Model/Types/{Security.hs => Auth.hs} | 8 ++++----
 src/Model/Types/Exam.hs                  | 2 +-
 src/Yesod/Servant.hs                     | 2 +-
 4 files changed, 7 insertions(+), 7 deletions(-)
 rename src/Model/Types/{Security.hs => Auth.hs} (97%)

diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index c3cd32a20..4e8a7d388 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -6,6 +6,7 @@ module Model.Types
   ( module Types
   ) where
 
+import Model.Types.Auth as Types
 import Model.Types.Common as Types
 import Model.Types.Course as Types
 import Model.Types.DateTime as Types
@@ -13,7 +14,6 @@ import Model.Types.Exam as Types
 import Model.Types.ExamOffice as Types
 import Model.Types.Health as Types
 import Model.Types.Mail as Types
-import Model.Types.Security as Types
 import Model.Types.Sheet as Types
 import Model.Types.Submission as Types
 import Model.Types.Misc as Types
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Auth.hs
similarity index 97%
rename from src/Model/Types/Security.hs
rename to src/Model/Types/Auth.hs
index e9ba741ae..d1e3900ff 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Auth.hs
@@ -1,16 +1,16 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 {-|
-Module: Model.Types.Security
+Module: Model.Types.Auth
 Description: Types for authentication and authorisation
 -}
 
-module Model.Types.Security
-  ( module Model.Types.Security
+module Model.Types.Auth
+  ( module Model.Types.Auth
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, Proxy(..))
diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs
index 986aa3871..83fb519f5 100644
--- a/src/Model/Types/Exam.hs
+++ b/src/Model/Types/Exam.hs
@@ -73,7 +73,7 @@ import qualified Data.Foldable
 
 import Data.Aeson (genericToJSON, genericParseJSON)
 
-import Model.Types.Security
+import Model.Types.Auth
 
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs
index 1c08c46fc..ff56f8a3e 100644
--- a/src/Yesod/Servant.hs
+++ b/src/Yesod/Servant.hs
@@ -30,7 +30,7 @@ import Control.Lens.Extras
 import Foundation.Servant.Types
 
 import Utils hiding (HasRoute)
-import Model.Types.Security
+import Model.Types.Auth
 
 import Yesod.Core ( Yesod
                   , RenderRoute(..), ParseRoute(..)

From 54f2430b3e79d3b7c396ac4cf1d4d0da860e3d02 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 11 Feb 2024 17:36:57 +0100
Subject: [PATCH 068/178] chore(model)!: separate user authentication data from
 User table; add ExternalAuth and InternalAuth models

---
 models/users.model      | 37 ++++++++++++++--------
 src/Model/Types/Auth.hs | 68 ++++++++++++++++++-----------------------
 2 files changed, 54 insertions(+), 51 deletions(-)

diff --git a/models/users.model b/models/users.model
index bba5b18a1..681e09055 100644
--- a/models/users.model
+++ b/models/users.model
@@ -13,13 +13,11 @@
 --
 
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
+    ident          UserIdent                -- Case-insensitive user-identifier
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
     email          UserEmail                -- Case-insensitive eMail address, used for sending  TODO: make this nullable
-    ident          UserIdent                -- Case-insensitive user-identifier
-    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash) -- TODO: redo (add InternalUser table for password hash)
-    lastAuthentication UTCTime Maybe        -- last login date
     created        UTCTime default=now()
     tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null)
     matrikelnummer UserMatriculation Maybe  -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
@@ -49,18 +47,33 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
-    UniqueAuthentication ident                  -- Column 'ident' can be used as a row-key in this table
+    UniqueUser  ident                           -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
--- User authentication data fetched from external sources
-ExternalUser
-    source            Text                 -- External source ID
-    ident             UserIdent            -- External user ID
-    data              Value "default='{}'::jsonb"  -- Raw user data from external source
-    lastSourceSync    UTCTime              -- When was the entry last synced with the external source?
-    lastUserSync      UTCTime Maybe        -- When was the corresponding User entry last synced with this entry? TODO: maybe move to User instead
-    UniqueExternalUser source ident
+-- | User authentication data, source-agnostic data
+UserAuth
+    ident     UserIdent                    -- Human-readable text uniquely identifying a user
+    lastLogin UTCTime                      -- When did the corresponding User last authenticate using this entry?
+    Primary ident
+    UniqueAuthentication ident
+    deriving Show Eq Ord Generic
+
+-- | User authentication data fetched from external user sources
+ExternalAuth
+    ident     UserIdent
+    source    AuthenticationSourceIdent    -- Identifier of the external source in the config
+    data      Value "default='{}'::jsonb"  -- Raw user data from external source
+    lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source?
+    UniqueExternalAuth ident source        -- At most one entry of this user per source
+    deriving Show Eq Ord Generic
+
+-- | FraDrive-specific user authentication data, internal logins have precedence over external authentication
+InternalAuth
+    ident     UserIdent
+    hash      Text                         -- Hashed password
+    Primary ident
+    UniqueInternalAuth ident
     deriving Show Eq Ord Generic
 
 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index d1e3900ff..3a9538ff9 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -15,61 +15,51 @@ module Model.Types.Auth
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, Proxy(..))
 
-import Utils
-
-import Data.Aeson
-import Data.Aeson.TH
 import Model.Types.TH.JSON
-import Data.Universe
-import Data.Universe.Instances.Reverse ()
-import Data.Proxy
-import Data.Data (Data)
+import Model.Types.TH.PathPiece
+
+import Utils
+import Utils.Lens.TH
 
 import Control.Lens
 
-import qualified Data.Set as Set
-
-import qualified Data.Text as Text
-
-import qualified Data.HashMap.Strict as HashMap
-
+import Data.Aeson
+import Data.Aeson.TH
 import qualified Data.Aeson.Types as Aeson
-
-import Data.CaseInsensitive (CI)
+import qualified Data.Binary as Binary
+import Data.Binary (Binary)
+import Data.Binary.Instances.UnorderedContainers ()
 import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
-
-import Data.Set.Instances ()
+import Data.Data (Data)
+import qualified Data.HashMap.Strict as HashMap
 import Data.NonNull.Instances ()
+import Data.Proxy
+import qualified Data.Set as Set
+import Data.Set.Instances ()
+import qualified Data.Text as Text
+import Data.Universe
+import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
 
-import Model.Types.TH.PathPiece
 import Database.Persist.Sql
 
 import Servant.Docs (ToSample(..), samples)
-import Utils.Lens.TH
-
-import Data.Binary (Binary)
-import qualified Data.Binary as Binary
-import Data.Binary.Instances.UnorderedContainers ()
 
 
-data AuthenticationMode = AuthLDAP
-                        | AuthAzure
-                        | AuthPWHash { authPWHash :: Text }
-                        | AuthNoLogin
-  deriving (Eq, Ord, Read, Show, Generic)
+-- | Supported protocols for external user sources used for authentication queries
+data AuthenticationProtocol
+  = AuthAzure -- ^ Azure ADv2 (OAuth2)
+  | AuthLdap  -- ^ LDAP
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic)
+  deriving anyclass (Universe, Finite, Hashable, NFData)
 
-instance Hashable AuthenticationMode
-instance NFData AuthenticationMode
+nullaryPathPiece ''AuthenticationProtocol $ camelToPathPiece' 1
+pathPieceJSON ''AuthenticationProtocol
 
-deriveJSON defaultOptions
-  { constructorTagModifier  = camelToPathPiece' 1
-  , fieldLabelModifier      = camelToPathPiece' 1
-  , sumEncoding             = UntaggedValue
-  } ''AuthenticationMode
 
-derivePersistFieldJSON ''AuthenticationMode
+type AuthenticationSourceIdent = Text
 
 
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
@@ -106,8 +96,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthRegisterGroup
   | AuthEmpty
   | AuthSelf
-  | AuthIsLDAP
-  | AuthIsPWHash
+  | AuthIsExternal -- TODO: maybe distinguish between AuthenticationProtocols
+  | AuthIsInternal
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead

From 938423b832bcbe19e1190193481bc0070c3cb505 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 11 Feb 2024 17:39:42 +0100
Subject: [PATCH 069/178] chore(auth): AuthTagLDAP -> AuthTagExternal,
 AuthTagPWHash -> AuthTagInternal

---
 .../categories/authorization/de-de-formal.msg |  4 ++--
 .../categories/authorization/en-eu.msg        |  4 ++--
 .../settings/auth_settings/de-de-formal.msg   |  6 +++---
 .../settings/auth_settings/en-eu.msg          |  6 +++---
 src/Foundation/Authorization.hs               | 20 ++++++++++---------
 src/Foundation/I18n.hs                        |  2 --
 6 files changed, 21 insertions(+), 21 deletions(-)

diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg
index 026a6aa62..80657d3e5 100644
--- a/messages/uniworx/categories/authorization/de-de-formal.msg
+++ b/messages/uniworx/categories/authorization/de-de-formal.msg
@@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Ausbilder:innen dürfen diesen Kurs nicht edit
 UnauthorizedCourseTutor: Sie sind nicht Ausbilder:in für diese Kursart.
 UnauthorizedTutor: Sie sind nicht Ausbilder:in.
 UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Kurs mit derselben Registrierungs-Gruppe eingetragen.
-UnauthorizedLDAP: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit Fraport Login an.
-UnauthorizedPWHash: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit FRADrive-Kennung an.
+UnauthorizedExternal: Angegebene:r Benuzter:in meldet sich nicht über einen aktuell unterstützten externen Login an.
+UnauthorizedInternal: Angegebene:r Benutzer:in meldet sich nicht mit FRADrive-Kennung an.
 UnauthorizedExternalExamListNotEmpty: Liste von externen Prüfungen ist nicht leer
 UnauthorizedExternalExamLecturer: Sie sind nicht als Prüfer:in für diese externe Prüfung eingetragen
 UnauthorizedSubmissionSubmissionGroup: Sie sind nicht Mitglied in einer der registrierten Abgabegruppen, die an dieser Abgabe beteiligt sind
diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg
index bc76b9a6e..2519242e4 100644
--- a/messages/uniworx/categories/authorization/en-eu.msg
+++ b/messages/uniworx/categories/authorization/en-eu.msg
@@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Instructors may not edit this course.
 UnauthorizedCourseTutor: You are no instructor for this course.
 UnauthorizedTutor: You are no instructor.
 UnauthorizedTutorialRegisterGroup: You are already registered for a course with the same registration group.
-UnauthorizedLDAP: Specified user does not log in with their Fraport password.
-UnauthorizedPWHash: Specified user does not log in with an FRADrive-account.
+UnauthorizedExternal: Specified user does not log in with any currently supported external login.
+UnauthorizedInternal: Specified user does not log in with a FRADrive-account.
 UnauthorizedExternalExamListNotEmpty: List of external exams is not empty
 UnauthorizedExternalExamLecturer: You are not an associated person for this external exam
 UnauthorizedSubmissionSubmissionGroup: You are not member in any of the submission groups for this submission
diff --git a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg
index e558668d3..b8f442862 100644
--- a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg
+++ b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,8 +45,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursartteilnehmer:innen
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektor:innen
 AuthTagCorrectionAnonymous: Korrektur ist anonymisiert
 AuthTagSelf: Nutzer:in greift nur auf eigene Daten zu
-AuthTagIsLDAP: Nutzer:in meldet sich mit Fraport AG Kennung an
-AuthTagIsPWHash: Nutzer:in meldet sich mit FRADrive spezifischer Kennung an
+AuthTagIsExternal: Nutzer:in meldet sich mit extern verwalteten Logindaten an
+AuthTagIsInternal: Nutzer:in meldet sich mit FRADrive-internen Logindaten an
 AuthTagAuthentication: Nutzer:in ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend
diff --git a/messages/uniworx/categories/settings/auth_settings/en-eu.msg b/messages/uniworx/categories/settings/auth_settings/en-eu.msg
index 562846f1a..5ba42ba0f 100644
--- a/messages/uniworx/categories/settings/auth_settings/en-eu.msg
+++ b/messages/uniworx/categories/settings/auth_settings/en-eu.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,8 +45,8 @@ AuthTagUserSubmissions: Submissions are made by course type participants
 AuthTagCorrectorSubmissions: Submissions are registered by correctors
 AuthTagCorrectionAnonymous: Correction is anonymised
 AuthTagSelf: User is only accessing their only data
-AuthTagIsLDAP: User logs in using their Fraport AG account
-AuthTagIsPWHash: User logs in using their FRADrive specific account
+AuthTagIsExternal: User logs in using externally managed credentials
+AuthTagIsInternal: User logs in using FRADrive-internal credentials
 AuthTagAuthentication: User is authenticated
 AuthTagRead: Access is read only
 AuthTagWrite: Access might write
diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index 0243b0609..4f36e5e31 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -1521,7 +1521,7 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
       | uid == referencedUser -> return Authorized
     Nothing -> return AuthenticationRequired
     _other  -> unauthorizedI MsgUnauthorizedSelf
-tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1529,13 +1529,15 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $
     UserNotificationR cID -> return cID
     UserPasswordR cID -> return cID
     CourseR _ _ _ (CUserR cID) -> return cID
-    _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
     User{..} <- MaybeT $ get referencedUser'
-    guard $ userAuthentication == AuthLDAP
+    let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
+    guardM . lift $ exists [ ExternalAuthIdent ==. userIdent, ExternalAuthSource <-. availableSources ]
+    guardM . lift . fmap not . existsBy $ UniqueInternalAuth userIdent
   return Authorized
-tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1543,11 +1545,11 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return
     UserNotificationR cID -> return cID
     UserPasswordR cID -> return cID
     CourseR _ _ _ (CUserR cID) -> return cID
-    _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsInternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedInternal) $ do
     User{..} <- MaybeT $ get referencedUser'
-    guard $ is _AuthPWHash userAuthentication
+    guardM . lift . existsBy $ UniqueInternalAuth userIdent
   return Authorized
 tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs
index fd2bb9479..98096978e 100644
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@@ -384,8 +384,6 @@ embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
 embedRenderMessage ''UniWorX ''ChangelogItemKind id
 embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
 
-embedRenderMessage ''UniWorX ''AuthenticationMode id
-
 embedRenderMessage ''UniWorX ''RatingValidityException id
 
 embedRenderMessage ''UniWorX ''UrlFieldMessage id

From 29fc20129476ba0738a90c2ac715f815eeeb25d3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 11 Feb 2024 17:40:46 +0100
Subject: [PATCH 070/178] chore(auth): authenticate against new
 InternalAuthHash in internal login AuthPlugin

---
 src/Auth/PWHash.hs | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs
index e857d8dcc..8dfef326b 100644
--- a/src/Auth/PWHash.hs
+++ b/src/Auth/PWHash.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -68,12 +68,12 @@ hashLogin pwHashAlgo = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
-        user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
-        case user of
-          Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
-            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic.
+        auth :: Maybe (Entity InternalAuth) <- liftHandler . runDB . getBy $ UniqueInternalAuth hashIdent
+        case auth of
+          Just (Entity _ InternalAuth{..})
+            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 internalAuthHash) -> do -- (2^) is magic.
                 observeLoginOutcome apName LoginSuccessful
-                setCredsRedirect $ Creds apName userIdent []
+                setCredsRedirect $ Creds apName (CI.original internalAuthIdent) []
           other -> do
             $logDebugS apName $ tshow other
             observeLoginOutcome apName LoginInvalidCredentials

From 42c97924ecc6173d065eaf5baf618fa917d4a070 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 11 Feb 2024 17:41:22 +0100
Subject: [PATCH 071/178] chore: remove debris

---
 src/Utils/Lens.hs | 2 --
 1 file changed, 2 deletions(-)

diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 5e5f993c6..4c00b0231 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -260,8 +260,6 @@ makeLenses_ ''ExamOccurrence
 
 makeLenses_ ''ExamOfficeLabel
 
-makePrisms ''AuthenticationMode
-
 makeLenses_ ''CourseUserNote
 makeLenses_ ''CourseParticipant
 

From bbeebc641ee89a98f70616b1e722ac6b461e302a Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Mon, 12 Feb 2024 15:06:30 +0000
Subject: [PATCH 072/178] chore(auth): new port offset calculation

---
 .ports/assign.hs | 64 ++++++++++++++++++++++++++++++++++++++++++++++++
 .ports/offsets   | 24 ++++++++++++++++++
 shell.nix        |  8 +++---
 3 files changed, 93 insertions(+), 3 deletions(-)
 create mode 100644 .ports/assign.hs
 create mode 100644 .ports/offsets

diff --git a/.ports/assign.hs b/.ports/assign.hs
new file mode 100644
index 000000000..000881729
--- /dev/null
+++ b/.ports/assign.hs
@@ -0,0 +1,64 @@
+-- SPDX-FileCopyrightText: 2024 David Mosbach 
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# Language OverloadedStrings, LambdaCase, TypeApplications #-}
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory
+import System.Environment
+import System.IO
+
+main :: IO ()
+main = getArgs >>= \case
+  ["--assign", offsetFile] -> parseOffsets offsetFile >>= uncurry nextOffset
+  ["--remove", offset] -> removeOffset offset
+  _ -> fail "unsupported args"
+
+parseOffsets :: FilePath -> IO (Int,Int)
+parseOffsets offsetFile = do
+  user <- T.pack <$> getEnv "USER"
+  let pred x = "//" `T.isPrefixOf` x || T.null (T.strip x)
+      tokenise = map (filter (not . pred) . T.lines) . T.split (=='#')
+      extract = map tail . filter (\u -> not (null u) && user == (T.strip $ head u))
+  ((extract . tokenise . T.pack) <$> readFile offsetFile) >>= \case
+    [[min,max]] -> return (read $ T.unpack min, read $ T.unpack max)
+    x -> print x >> fail "malformed offset file"
+
+nextOffset :: Int -> Int -> IO ()
+nextOffset min max
+  | min > max = nextOffset max min
+  | otherwise = do
+      home <- getEnv "HOME"
+      offset <- findFile [home] ".port-offsets" >>= \case
+        Nothing   -> writeFile (home ++ "/.port-offsets") (show min) >> return min
+        Just path -> do
+          used <- (map (read @Int) . filter (not . null) . lines) <$> readFile path
+          o <- next min max used
+          appendFile path ('\n' : show o)
+          return o
+      print offset
+        where
+          next :: Int -> Int -> [Int] -> IO Int
+          next min max used
+            | min > max = fail "all offsets currently in use"
+            | min `elem` used = next (min+1) max used
+            | otherwise = return min
+
+removeOffset :: String -> IO ()
+removeOffset offset = do
+  home <- getEnv "HOME"
+  findFile [home] ".port-offsets" >>= \case
+    Nothing   -> fail "offset file does not exist"
+    Just path -> do
+      remaining <- (filter (/= offset) . lines) <$> readFile path
+      run <- getEnv "XDG_RUNTIME_DIR"
+      (tempPath, fh) <- openTempFile run ".port-offsets"
+      let out = unlines remaining
+      hPutStr fh $ out
+      case T.null (T.strip $ T.pack out) of
+        True -> removeFile path
+        False -> writeFile path $ out
+      removeFile tempPath
+
diff --git a/.ports/offsets b/.ports/offsets
new file mode 100644
index 000000000..7a4e5e7d6
--- /dev/null
+++ b/.ports/offsets
@@ -0,0 +1,24 @@
+// SPDX-FileCopyrightText: 2024 David Mosbach 
+//
+// SPDX-License-Identifier: AGPL-3.0-or-later
+
+# gkleen
+  -1000
+  -950
+
+# ishka
+  -949
+  -899
+
+# jost
+  -898
+  -848
+
+# mosbach
+  -847
+  -797
+
+# savau
+  -796
+  -746
+
diff --git a/shell.nix b/shell.nix
index 58494040a..8c3f8b97e 100644
--- a/shell.nix
+++ b/shell.nix
@@ -63,6 +63,7 @@ let
       type cleanup_maildev &>/dev/null && cleanup_maildev
       [[ -z "$OAUTH2_PGDIR" ]] || source ${killOauth2DB}/bin/killOauth2DB
       [[ -z "$OAUTH2_PGHOST" ]] || pkill oauth2-mock-ser
+      [[ -z "$PORT_OFFSET" ]] || runghc .ports/assign.hs --remove $PORT_OFFSET
 
       [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env"
       set +x
@@ -70,10 +71,13 @@ let
 
     trap cleanup EXIT
 
-    export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000))
+    export PORT_OFFSET=$(runghc .ports/assign.hs --assign .ports/offsets)
+    # export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000))
 
     if [[ -z "$OAUTH2_PGHOST" ]]; then
       set -xe
+      export OAUTH2_SERVER_PORT=$((9443 + $PORT_OFFSET))
+      export OAUTH2_DB_PORT=$((9444 + $PORT_OFFSET))
       source ${mkOauth2DB}/bin/mkOauth2DB
       ${oauth2MockServer}/bin/oauth2-mock-server&
       set +xe
@@ -300,8 +304,6 @@ in pkgs.mkShell {
   OAUTH2_HBA = oauth2Hba;
   OAUTH2_DB_SCHEMA = oauth2Schema;
   OAUTH2_TEST_USERS = ./test/Database/test-users.yaml;
-  OAUTH2_SERVER_PORT = 9443;
-  OAUTH2_DB_PORT = 9444;
   nativeBuildInputs = [develop inDevelop killallUni2work diffRunning]
   ++ (with pkgs;
     [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client

From 7803b753cb9e18770ca1cabb02abcfe2e81a94b5 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 13 Feb 2024 17:38:22 +0100
Subject: [PATCH 073/178] refactor(model): migrate auth models and model types
 to models/auth.model

---
 models/auth.model       | 28 ++++++++++++++++++++++++++++
 models/users.model      | 25 -------------------------
 src/Model/Types/Auth.hs |  3 +++
 src/Model/Types/User.hs |  5 +----
 4 files changed, 32 insertions(+), 29 deletions(-)
 create mode 100644 models/auth.model

diff --git a/models/auth.model b/models/auth.model
new file mode 100644
index 000000000..0272a2d4b
--- /dev/null
+++ b/models/auth.model
@@ -0,0 +1,28 @@
+-- SPDX-FileCopyrightText: 2024 Sarah Vaupel 
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+-- | User authentication data, source-agnostic data
+UserAuth
+    ident     UserIdent                    -- Human-readable text uniquely identifying a user
+    lastLogin UTCTime                      -- When did the corresponding User last authenticate using this entry?
+    Primary ident
+    UniqueAuthentication ident
+    deriving Show Eq Ord Generic
+
+-- | User authentication data fetched from external user sources
+ExternalAuth
+    ident     UserIdent
+    source    AuthenticationSourceIdent    -- Identifier of the external source in the config
+    data      Value "default='{}'::jsonb"  -- Raw user data from external source
+    lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source?
+    UniqueExternalAuth ident source        -- At most one entry of this user per source
+    deriving Show Eq Ord Generic
+
+-- | FraDrive-specific user authentication data, internal logins have precedence over external authentication
+InternalAuth
+    ident     UserIdent
+    hash      Text                         -- Hashed password
+    Primary ident
+    UniqueInternalAuth ident
+    deriving Show Eq Ord Generic
diff --git a/models/users.model b/models/users.model
index 681e09055..739b73688 100644
--- a/models/users.model
+++ b/models/users.model
@@ -51,31 +51,6 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
--- | User authentication data, source-agnostic data
-UserAuth
-    ident     UserIdent                    -- Human-readable text uniquely identifying a user
-    lastLogin UTCTime                      -- When did the corresponding User last authenticate using this entry?
-    Primary ident
-    UniqueAuthentication ident
-    deriving Show Eq Ord Generic
-
--- | User authentication data fetched from external user sources
-ExternalAuth
-    ident     UserIdent
-    source    AuthenticationSourceIdent    -- Identifier of the external source in the config
-    data      Value "default='{}'::jsonb"  -- Raw user data from external source
-    lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source?
-    UniqueExternalAuth ident source        -- At most one entry of this user per source
-    deriving Show Eq Ord Generic
-
--- | FraDrive-specific user authentication data, internal logins have precedence over external authentication
-InternalAuth
-    ident     UserIdent
-    hash      Text                         -- Hashed password
-    Primary ident
-    UniqueInternalAuth ident
-    deriving Show Eq Ord Generic
-
 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
     user     UserId
     school   SchoolId
diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index 3a9538ff9..92b2eb0d5 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -48,6 +48,9 @@ import Database.Persist.Sql
 import Servant.Docs (ToSample(..), samples)
 
 
+type UserEduPersonPrincipalName = Text
+
+
 -- | Supported protocols for external user sources used for authentication queries
 data AuthenticationProtocol
   = AuthAzure -- ^ Azure ADv2 (OAuth2)
diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs
index 64cb539d9..7938f0763 100644
--- a/src/Model/Types/User.hs
+++ b/src/Model/Types/User.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -8,9 +8,6 @@ import Import.NoModel
 import Model.Types.TH.PathPiece
 
 
-type UserEduPersonPrincipalName = Text
-
-
 data SystemFunction
   = SystemExamOffice
   | SystemFaculty

From 2c3292cadf6a260080a2414bd290321d797448c8 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 13 Feb 2024 18:22:00 +0100
Subject: [PATCH 074/178] chore(model): add authentication source models

---
 models/auth.model | 29 +++++++++++++++++++++++++++++
 1 file changed, 29 insertions(+)

diff --git a/models/auth.model b/models/auth.model
index 0272a2d4b..68bb8516b 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -2,6 +2,35 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+
+-- | AzureADv2 (Microsoft Graph) user authentication sources, parsed from application settings
+-- | Note: No host specification is needed since Azure authentication is always requested at https://graph.microsoft.com/ (Microsoft Graph API)
+AuthSourceAzure
+  clientId       UUID         -- ^ Azure Client ID of this application
+  clientSecret   Text         -- ^ Azure Client Secret of this application
+  tenantId       UUID         -- ^ Azure Tenant ID of the Azure source
+  scopes         AzureScopes  -- ^ Azure Scopes this application (client) is authorized for
+  UniqueAuthSourceAzure clientId -- TODO rethink!
+  Primary clientId -- TODO rethink!
+  deriving Show Eq Ord Generic
+
+-- | LDAP user authentication sources, parsed from application settings
+AuthSourceLdap
+  host           Text         -- ^ LDAP host destination to connect to
+                              -- TODO: switch to url type
+  port           Natural      -- ^ Port of the LDAP service to connect to
+                              -- TODO: is there a port type? Maybe merge with host and make primary key?
+  tls            Bool         -- ^ Whether to connect to the host via TLS
+  user           Text         -- ^ User used for queries
+  pass           Text         -- ^ Password used for queries
+  baseDn         Text
+  scope          LdapScope
+  timeout        Natural      -- ^ Query timeout in milliseconds
+  searchTimeout  Natural      -- ^ Search query timeout in milliseconds
+  UniqueAuthSourceLdap host port -- TODO rethink!
+  deriving Show Eq Ord Generic
+
+
 -- | User authentication data, source-agnostic data
 UserAuth
     ident     UserIdent                    -- Human-readable text uniquely identifying a user

From 1180ef6fd0d6e6e4b2c3625988cb0e77e45c0521 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 13 Feb 2024 19:01:49 +0100
Subject: [PATCH 075/178] chore(ldap): add Ldap.Scope instances

---
 src/Ldap/Client/Instances.hs | 22 +++++++++++++++++++++-
 1 file changed, 21 insertions(+), 1 deletion(-)

diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs
index ca2689934..1d8b7f3ac 100644
--- a/src/Ldap/Client/Instances.hs
+++ b/src/Ldap/Client/Instances.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,7 +9,27 @@ module Ldap.Client.Instances
   ) where
 
 import ClassyPrelude
+
+import Data.Data (Data)
+
+import Database.Persist.TH (derivePersistField)
+
+import Utils.PathPiece (derivePathPiece)
+
 import Ldap.Client
 
 
 deriving instance Ord ResultCode
+deriving instance Ord Scope
+
+deriving instance Read Scope
+
+deriving instance Data Scope
+
+deriving instance Generic Scope
+
+deriving instance NFData Scope
+
+derivePathPiece ''Scope id "--"
+
+derivePersistField "Scope"

From 7ed5e7a3261dc0fb9fe68f34d21380af956fa8c7 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 13 Feb 2024 22:44:30 +0100
Subject: [PATCH 076/178] chore(model): use more specific (new)types for ldap
 model

---
 models/auth.model       | 16 +++++++-------
 src/Auth/LDAP.hs        | 14 ++++++------
 src/Import/NoModel.hs   |  1 +
 src/Model/Types/Auth.hs | 49 ++++++++++++++++++++++++++++++++++++++++-
 src/Settings.hs         |  1 -
 src/Settings/Ldap.hs    | 40 ++++++++++++++++-----------------
 6 files changed, 84 insertions(+), 37 deletions(-)

diff --git a/models/auth.model b/models/auth.model
index 68bb8516b..e8092fe57 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -18,15 +18,15 @@ AuthSourceAzure
 AuthSourceLdap
   host           Text         -- ^ LDAP host destination to connect to
                               -- TODO: switch to url type
-  port           Natural      -- ^ Port of the LDAP service to connect to
-                              -- TODO: is there a port type? Maybe merge with host and make primary key?
+  port           Word16       -- ^ Port of the LDAP service to connect to
+                              -- TODO: Maybe merge with host and make primary key?
   tls            Bool         -- ^ Whether to connect to the host via TLS
-  user           Text         -- ^ User used for queries
-  pass           Text         -- ^ Password used for queries
-  baseDn         Text
-  scope          LdapScope
-  timeout        Natural      -- ^ Query timeout in milliseconds
-  searchTimeout  Natural      -- ^ Search query timeout in milliseconds
+  user           LdapDn       -- ^ User used for queries
+  pass           LdapPass     -- ^ Password used for queries
+  base           LdapDn       -- ^ TODO documentation needed
+  scope          LdapScope    -- ^ TODO documentation needed
+  timeout        NominalDiffTime  -- ^ Query timeout
+  searchTimeout  Int32            -- ^ Search query timeout -- TODO: why not NominalDiffTime??
   UniqueAuthSourceLdap host port -- TODO rethink!
   deriving Show Eq Ord Generic
 
diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index c8650bc44..84603bb00 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -65,7 +65,7 @@ findUser :: LdapConf
          -> Text -- ^ needle
          -> [Ldap.Attr]
          -> IO [Ldap.SearchEntry]
-findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
+findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
   where
     userFilters =
       [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
@@ -85,7 +85,7 @@ findUserMatr :: LdapConf
              -> Text -- ^ matriculation needle
              -> [Ldap.Attr]
              -> IO [Ldap.SearchEntry]
-findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
+findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
   where
     userFilters =
       [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
@@ -94,9 +94,9 @@ findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (
 userSearchSettings :: LdapConf
                    -> Ldap.Mod Ldap.Search
 userSearchSettings LdapConf{..} = mconcat
-  [ Ldap.scope ldapScope
+  [ Ldap.scope ldapConfScope
   , Ldap.size 2
-  , Ldap.time ldapSearchTimeout
+  , Ldap.time ldapConfSearchTimeout
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
@@ -147,7 +147,7 @@ ldapUserWith :: ( MonadUnliftIO m
              -> Creds site
              -> m (Either LdapUserException (Ldap.AttrList []))
 ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
-  lift $ Ldap.bind ldap ldapDn ldapPassword
+  lift $ Ldap.bind ldap ldapConfDn ldapConfPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do
       let userFilter = Ldap.Present ldapUserPrincipalName
@@ -224,7 +224,7 @@ ldapUserMatr :: ( MonadUnliftIO m
              -> UserMatriculation
              -> m (Ldap.AttrList [])
 ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
-  Ldap.bind ldap ldapDn ldapPassword
+  Ldap.bind ldap ldapConfDn ldapConfPassword
   results <- findUserMatr conf ldap userMatr []
   case results of
     [] -> throwM LdapUserNoResult
@@ -286,7 +286,7 @@ ldapLogin conf@LdapConf{..} pool = AuthPlugin{..}
 
       resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do
         ldapResult <- withLdap pool $ \ldap -> liftIO $ do
-          Ldap.bind ldap ldapDn ldapPassword
+          Ldap.bind ldap ldapConfDn ldapConfPassword
           searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
           case searchResults of
             [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 90edef7a1..d5bd8072e 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -252,6 +252,7 @@ import Data.Encoding.UTF8 as Import (UTF8(UTF8))
 
 import GHC.TypeLits as Import (KnownSymbol)
 
+import Data.Word as Import (Word16)
 import Data.Word.Word24 as Import
 
 import Data.Kind as Import (Type, Constraint)
diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index 92b2eb0d5..94edadd84 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -43,15 +43,54 @@ import Data.Universe
 import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
 
+import qualified Database.Esqueleto.Legacy as E
 import Database.Persist.Sql
 
+import qualified Ldap.Client as Ldap
+import Ldap.Client.Instances ()
+
 import Servant.Docs (ToSample(..), samples)
 
 
+type AzureScopes = Set Text
+
+-- Note: Ldap.Host also stores TLS settings, which we will generate ad-hoc based on AuthSourceLdapTls field instead. We therefore use Text to store the hostname only
+-- newtype LdapHost = LdapHost { ldapHost :: Text }
+--   deriving (Eq, Ord, Read, Show, Generic, Data)
+--   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
+-- instance E.SqlString LdapHost
+-- makeLenses_ ''LdapHost
+
+-- Note: Ldap.PortNumber comes from Network.Socket, which does not export the constructor of the newtype. Hence, no Data and Generic instances can be derived. But PortNumber is a member of Num, so we will use Word16 instead (Word16 is also used for storing the port number inside PortNumber)
+-- newtype LdapPort = LdapPort { ldapPort :: Word16 }
+--   deriving (Eq, Ord, Read, Show, Generic, Data)
+--   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
+-- instance E.SqlString LdapPort
+-- makeLenses_ ''LdapPort
+
+newtype LdapPass = LdapPass { ldapPass :: Ldap.Password }
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (NFData, PersistField, PersistFieldSql)
+instance E.SqlString LdapPass
+makeLenses_ ''LdapPass
+
+newtype LdapDn = LdapDn { ldapDn :: Ldap.Dn }
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
+instance E.SqlString LdapDn
+makeLenses_ ''LdapDn
+
+newtype LdapScope = LdapScope { ldapScope :: Ldap.Scope }
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
+instance E.SqlString LdapScope
+makeLenses_ ''LdapScope
+
 type UserEduPersonPrincipalName = Text
 
 
 -- | Supported protocols for external user sources used for authentication queries
+-- TODO: deprecated, delete
 data AuthenticationProtocol
   = AuthAzure -- ^ Azure ADv2 (OAuth2)
   | AuthLdap  -- ^ LDAP
@@ -62,9 +101,14 @@ nullaryPathPiece ''AuthenticationProtocol $ camelToPathPiece' 1
 pathPieceJSON ''AuthenticationProtocol
 
 
+-- TODO: delete once identification using model table is implemented
 type AuthenticationSourceIdent = Text
 
 
+-------------------
+----- AuthTag -----
+-------------------
+
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
   | AuthLecturer
@@ -173,6 +217,10 @@ _ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags
     fromReducedActiveAuthTags (ReducedActiveAuthTags hm) = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm
 
 
+-------------------
+----- PredDNF -----
+-------------------
+
 data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
   deriving (Eq, Ord, Read, Show, Data, Generic)
   deriving anyclass (Hashable, Binary, NFData)
@@ -214,7 +262,6 @@ parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM pa
       | otherwise
         = Left t
 
-
 $(return [])
 
 instance ToJSON a => ToJSON (PredDNF a) where
diff --git a/src/Settings.hs b/src/Settings.hs
index 242b0ca0d..45f1e0c89 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -44,7 +44,6 @@ import           Language.Haskell.TH.Syntax  (Exp, Q)
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import qualified Data.Scientific as Scientific
-import Data.Word (Word16)
 
 import qualified Data.Text as Text
 
diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs
index 88df04e9d..1ef5081be 100644
--- a/src/Settings/Ldap.hs
+++ b/src/Settings/Ldap.hs
@@ -6,7 +6,7 @@
 
 module Settings.Ldap
   ( LdapConf(..)
-  , _ldapHost, _ldapDn, _ldapBase, _ldapScope, _ldapTimeout, _ldapSearchTimeout
+  , _ldapConfHost, _ldapConfDn, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout
   ) where
 
 import ClassyPrelude
@@ -24,24 +24,24 @@ import qualified Ldap.Client as Ldap
 
 
 data LdapConf = LdapConf
-  { ldapHost     :: Ldap.Host
-  , ldapPort     :: Ldap.PortNumber
-  , ldapDn       :: Ldap.Dn
-  , ldapPassword :: Ldap.Password
-  , ldapBase     :: Ldap.Dn
-  , ldapScope    :: Ldap.Scope
-  , ldapTimeout  :: NominalDiffTime
-  , ldapSearchTimeout :: Int32
+  { ldapConfHost     :: Ldap.Host
+  , ldapConfPort     :: Ldap.PortNumber
+  , ldapConfDn       :: Ldap.Dn
+  , ldapConfPassword :: Ldap.Password
+  , ldapConfBase     :: Ldap.Dn
+  , ldapConfScope    :: Ldap.Scope
+  , ldapConfTimeout  :: NominalDiffTime
+  , ldapConfSearchTimeout :: Int32
   } deriving (Show)
 
 makeLenses_ ''LdapConf
 
-deriveFromJSON defaultOptions ''Ldap.Scope
+deriveFromJSON defaultOptions ''Ldap.Scope -- TODO: move to Ldap.Client.Instances
 
 instance FromJSON LdapConf where
   parseJSON = withObject "LdapConf" $ \o -> do
-    ldapTls <- o .:? "tls"
-    tlsSettings <- case ldapTls :: Maybe String of
+    ldapConfTls <- o .:? "tls"
+    tlsSettings <- case ldapConfTls :: Maybe String of
       Just spec
         | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
         | spec == "default"  -> return $ Just Ldap.defaultTlsSettings
@@ -50,12 +50,12 @@ instance FromJSON LdapConf where
         | null spec          -> return Nothing
       Nothing                -> return Nothing
       _otherwise             -> fail "Could not parse LDAP TLSSettings"
-    ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= ""
-    ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
-    ldapDn <- Ldap.Dn <$> o .:? "user" .!= ""
-    ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
-    ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
-    ldapScope <- o .: "scope"
-    ldapTimeout <- o .: "timeout"
-    ldapSearchTimeout <- o .: "search-timeout"
+    ldapConfHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= ""
+    ldapConfPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+    ldapConfDn <- Ldap.Dn <$> o .:? "user" .!= ""
+    ldapConfPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
+    ldapConfBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
+    ldapConfScope <- o .: "scope"
+    ldapConfTimeout <- o .: "timeout"
+    ldapConfSearchTimeout <- o .: "search-timeout"
     return LdapConf{..}

From 9597663881afad2badb9ff4265294eb70d561e1e Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 13 Feb 2024 22:44:47 +0100
Subject: [PATCH 077/178] chore(ldap): add more Ldap instances

---
 src/Ldap/Client/Instances.hs | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs
index 1d8b7f3ac..5a3a80cab 100644
--- a/src/Ldap/Client/Instances.hs
+++ b/src/Ldap/Client/Instances.hs
@@ -19,17 +19,30 @@ import Utils.PathPiece (derivePathPiece)
 import Ldap.Client
 
 
+deriving instance Ord Dn
+deriving instance Ord Password
 deriving instance Ord ResultCode
 deriving instance Ord Scope
 
+deriving instance Read Dn
+deriving instance Read Password
 deriving instance Read Scope
 
+deriving instance Data Dn
+deriving instance Data Password
 deriving instance Data Scope
 
+deriving instance Generic Dn
+deriving instance Generic Password
 deriving instance Generic Scope
 
+deriving anyclass instance NFData Dn
+deriving anyclass instance NFData Password
 deriving instance NFData Scope
 
+derivePathPiece ''Dn id "--"
 derivePathPiece ''Scope id "--"
 
+derivePersistField "Dn"
+derivePersistField "Password"
 derivePersistField "Scope"

From 0c5f4cb43034f8c85e3dc532b23d075564ddda11 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 14 Feb 2024 02:02:42 +0100
Subject: [PATCH 078/178] refactor(settings): use better settings type names
 for user-auth

---
 config/settings.yml    |  5 +++--
 src/Settings.hs        | 37 +++++++++++++++++++------------------
 src/Settings/OAuth2.hs | 13 ++++++-------
 3 files changed, 28 insertions(+), 27 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index c7f3018e2..bb8047209 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -128,8 +128,8 @@ database:
 
 auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
-# External sources used for authentication and userdata lookups
-user-source:
+# External sources used for user authentication and userdata lookups
+user-auth:
 # mode: single-source
   protocol: azureadv2
   config:
@@ -155,6 +155,7 @@ ldap-pool:
   timeout: "_env:LDAPTIMEOUT:20"
   limit:   "_env:LDAPLIMIT:10"
 
+# TODO: might move later
 # user-retest-failover: 60
 user-sync-within:   "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
 user-sync-interval: "_env:USER_SYNC_INTERVAL:3600"  # jede Stunde
diff --git a/src/Settings.hs b/src/Settings.hs
index 45f1e0c89..74a07929b 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -141,21 +141,22 @@ instance FromJSON PWHashConf where
     return PWHashConf{..}
 
 
-data UserSource = UserSourceLdap LdapConf | UserSourceAzureAdV2 AzureConf
+data AuthSourceConf = AuthSourceConfLdap LdapConf | AuthSourceConfAzureAdV2 AzureConf
   deriving (Show)
 
-data UserSourceConf =
-      UserSourceConfSingleSource -- ^ use only one specific source
-      { usersrcSingleSource :: UserSource
+data UserAuthConf =
+      UserAuthConfSingleSource -- ^ use only one specific source
+      { userAuthConfSingleSource :: AuthSourceConf
       }
   -- TODO: other modes yet to be implemented
-  -- | UserFailover  -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable
-  --   { usersrcFailoverSources :: PointedList UserSource
-  --   , usersrcFailoverRetest  :: NominalDiffTime
+  -- | UserAuthConfFailover  -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable
+  --   { userAuthConfFailoverSources :: PointedList UserSource
+  --   , userAuthConfFailoverRetest  :: NominalDiffTime
   --   }
-  -- | UserMultiSource  -- ^ Multiple coequal user sources
-  --   { usersrcMultiSources :: Set UserSource
+  -- | UserAuthConfMultiSource  -- ^ Multiple coequal user sources
+  --   { userAuthConfMultiSources :: Set UserSource
   --   }
+  -- | UserAuthConfNoSource -- ^ allow no external sources at all -- TODO: either this, or make user-auth in settings.yml optional
   deriving (Show)
 
 data LmsConf = LmsConf
@@ -308,21 +309,21 @@ pathPieceJSONKey ''SettingBotMitigation
 makePrisms ''JobMode
 makeLenses_ ''JobMode
 
-makePrisms ''UserSource
-makeLenses_ ''UserSourceConf
-makePrisms ''UserSourceConf
+makePrisms ''AuthSourceConf
+makeLenses_ ''UserAuthConf
+makePrisms ''UserAuthConf
 
 deriveFromJSON defaultOptions
-  { constructorTagModifier = toLower . dropPrefix "UserSource"
+  { constructorTagModifier = toLower . dropPrefix "AuthSourceConf"
   , sumEncoding = TaggedObject "protocol" "config"
-  } ''UserSource
+  } ''AuthSourceConf
 
 deriveFromJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 3
-  , fieldLabelModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 3
   , sumEncoding = UntaggedValue -- TaggedObject "mode" "config"
   , unwrapUnaryRecords = True
-  } ''UserSourceConf
+  } ''UserAuthConf
 
 instance FromJSON HaskellNet.PortNumber where
   parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of
@@ -450,7 +451,7 @@ data AppSettings = AppSettings
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
-    , appUserSourceConf         :: UserSourceConf
+    , appUserAuthConf           :: UserAuthConf
     -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
     , appLmsConf                :: LmsConf
     -- ^ Configuration settings for accessing the LDAP-directory
@@ -627,7 +628,7 @@ instance FromJSON AppSettings where
         --       Ldap.Tls host _ -> not $ null host
         --       Ldap.Plain host -> not $ null host
         --     nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
-        appUserSourceConf         <- o .: "user-source"
+        appUserAuthConf           <- o .: "user-auth"
         -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
         appLdapPoolConf           <- o .:? "ldap-pool"
         appLmsConf                <- o .: "lms-direct"
diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs
index a07bc606f..5242a776a 100644
--- a/src/Settings/OAuth2.hs
+++ b/src/Settings/OAuth2.hs
@@ -4,7 +4,7 @@
 
 module Settings.OAuth2
   ( AzureConf(..)
-  , _azureClientId, _azureClientSecret, _azureTenantId, _azureScopes
+  , _azureConfClientId, _azureConfClientSecret, _azureConfTenantId, _azureConfScopes
   ) where
 
 import ClassyPrelude
@@ -17,16 +17,15 @@ import Utils.Lens.TH
 import Utils.PathPiece (camelToPathPiece')
 
 
--- TODO: use better types
 data AzureConf = AzureConf
-  { azureClientId     :: UUID
-  , azureClientSecret :: Text
-  , azureTenantId     :: UUID
-  , azureScopes       :: Set Text -- TODO: use better type
+  { azureConfClientId     :: UUID
+  , azureConfClientSecret :: Text
+  , azureConfTenantId     :: UUID
+  , azureConfScopes       :: Set Text -- TODO: use AzureScopes type?
   } deriving (Show)
 
 makeLenses_ ''AzureConf
 
 deriveFromJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
+  { fieldLabelModifier = camelToPathPiece' 2
   } ''AzureConf

From f8bf02df2bb194899de886a52a7c62f7911e7e73 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 16 Feb 2024 02:26:24 +0100
Subject: [PATCH 079/178] chore(ldap): move and add more instances

---
 src/Auth/LDAP.hs             | 4 ----
 src/Ldap/Client/Instances.hs | 5 +++++
 2 files changed, 5 insertions(+), 4 deletions(-)

diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 84603bb00..f14e60683 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -42,10 +42,6 @@ apLdap :: Text
 apLdap = "LDAP"
 
 
--- | Allow Ldap.Attr usage as key for Data.Map
-deriving newtype instance Ord Ldap.Attr
-
-
 -- TODO: rename
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs
index 5a3a80cab..19c1ae6bf 100644
--- a/src/Ldap/Client/Instances.hs
+++ b/src/Ldap/Client/Instances.hs
@@ -19,23 +19,28 @@ import Utils.PathPiece (derivePathPiece)
 import Ldap.Client
 
 
+deriving instance Ord Attr
 deriving instance Ord Dn
 deriving instance Ord Password
 deriving instance Ord ResultCode
 deriving instance Ord Scope
 
+deriving instance Read Attr
 deriving instance Read Dn
 deriving instance Read Password
 deriving instance Read Scope
 
+deriving instance Data Attr
 deriving instance Data Dn
 deriving instance Data Password
 deriving instance Data Scope
 
+deriving instance Generic Attr
 deriving instance Generic Dn
 deriving instance Generic Password
 deriving instance Generic Scope
 
+deriving anyclass instance NFData Attr
 deriving anyclass instance NFData Dn
 deriving anyclass instance NFData Password
 deriving instance NFData Scope

From 848890d3cd63fe1fc41580e645c07beb04026070 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 16 Feb 2024 02:28:15 +0100
Subject: [PATCH 080/178] chore(auth): add more data to user upsert mode

---
 src/Foundation/Types.hs | 22 ++++++++++++++++++----
 1 file changed, 18 insertions(+), 4 deletions(-)

diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs
index 96e858dfe..0a2a4a97a 100644
--- a/src/Foundation/Types.hs
+++ b/src/Foundation/Types.hs
@@ -5,18 +5,32 @@
 module Foundation.Types
   ( UpsertUserMode(..)
   , _UpsertUserLoginLdap, _UpsertUserLoginAzure, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
-  , _upsertUserIdent
+  , _upsertUserLdapSource, _upsertUserLdapData, _upsertUserAzureSource, _upsertUserAzureData, _upsertUserIdent
   ) where
 
 import Import.NoFoundation
 
+import qualified Ldap.Client as Ldap
+
 
 data UpsertUserMode
   = UpsertUserLoginLdap
+    { upsertUserLdapSource  :: AuthSourceLdapId
+    , upsertUserLdapData    :: Ldap.AttrList []
+    }
   | UpsertUserLoginAzure
-  | UpsertUserLoginDummy { upsertUserIdent :: UserIdent }
-  | UpsertUserLoginOther { upsertUserIdent :: UserIdent } -- does not allow further login
-  | UpsertUserSync       { upsertUserIdent :: UserIdent }
+    { upsertUserAzureSource :: AuthSourceAzureId
+    , upsertUserAzureData   :: [(Text, [ByteString])]  -- TODO: use type synonym?
+    }
+  | UpsertUserLoginDummy
+    { upsertUserIdent       :: UserIdent
+    }
+  | UpsertUserLoginOther  -- does not allow further login
+    { upsertUserIdent       :: UserIdent
+    }
+  | UpsertUserSync
+    { upsertUserIdent       :: UserIdent
+    }
   | UpsertUserGuessUser
   deriving (Eq, Ord, Read, Show, Generic)
 

From a0e7b2f96cfbdc61e39e546a2f9fb610d739266a Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 16 Feb 2024 03:25:36 +0100
Subject: [PATCH 081/178] chore(auth): work on authenticate

---
 models/auth.model            |   3 +-
 src/Foundation/Instances.hs  |   7 +-
 src/Foundation/Navigation.hs |   4 +-
 src/Foundation/Yesod/Auth.hs | 485 ++++++++++++++++++++---------------
 4 files changed, 285 insertions(+), 214 deletions(-)

diff --git a/models/auth.model b/models/auth.model
index e8092fe57..69d0502b0 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -35,6 +35,7 @@ AuthSourceLdap
 UserAuth
     ident     UserIdent                    -- Human-readable text uniquely identifying a user
     lastLogin UTCTime                      -- When did the corresponding User last authenticate using this entry?
+    lastSync  UTCTime Maybe                -- When was the corresponding User entry last synced with any external source? -- TODO rethink
     Primary ident
     UniqueAuthentication ident
     deriving Show Eq Ord Generic
@@ -44,7 +45,7 @@ ExternalAuth
     ident     UserIdent
     source    AuthenticationSourceIdent    -- Identifier of the external source in the config
     data      Value "default='{}'::jsonb"  -- Raw user data from external source
-    lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source?
+    lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source? -- TODO rethink
     UniqueExternalAuth ident source        -- At most one entry of this user per source
     deriving Show Eq Ord Generic
 
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index df14e7de3..a076b389e 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt , David Mosbach 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -119,9 +119,9 @@ instance YesodPersistRunner UniWorX where
   getDBRunner :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
   getDBRunner = UniWorX.getDBRunner' callStack
 
-    
+
 instance YesodAuth UniWorX where
-    type AuthId UniWorX = UserId
+    type AuthId UniWorX = UserAuthId
 
     -- Where to send a user after successful login
     loginDest _ = NewsR
@@ -172,6 +172,7 @@ instance YesodAuth UniWorX where
               BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
               hoistMaybe bearerImpersonate
 
+-- TODO: update?
 instance YesodAuthPersist UniWorX where
   getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
   getAuthEntity = liftHandler . runDBRead . get
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index ce7d466f4..c9794f73e 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -1212,8 +1212,8 @@ pageActions (AdminUserR cID) = return
       , navRoute       = UserPasswordR cID
       , navAccess' = NavAccessDB $ do
           uid <- decrypt cID
-          User{userAuthentication} <- get404 uid
-          return $ is _AuthPWHash userAuthentication
+          User{userIdent} <- get404 uid
+          existsBy $ UniqueInternalAuth userIdent
       , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 9d0ffeed8..b43320fbd 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -5,52 +5,57 @@
 module Foundation.Yesod.Auth
   ( authenticate
   , ldapLookupAndUpsert
-  , upsertLdapUser, upsertAzureUser
+  , upsertUser
   , decodeLdapUserTest, decodeAzureUserTest
-  , CampusUserConversionException(..)
+  , UserConversionException(..)
   , updateUserLanguage
   ) where
 
 import Import.NoFoundation hiding (authenticate)
 
-import Foundation.Type
-import Foundation.Types
-import Foundation.I18n
-
-import Handler.Utils.Profile
-import Handler.Utils.LdapSystemFunctions
-import Handler.Utils.Memcached
-import Foundation.Authorization (AuthorizationCacheKey(..))
-
-import Yesod.Auth.Message
+import Auth.Dummy (apDummy)
 import Auth.LDAP
 import Auth.OAuth2
 import Auth.PWHash (apHash)
-import Auth.Dummy (apDummy)
 
-import qualified Data.CaseInsensitive as CI
 import qualified Control.Monad.Catch as C (Handler(..))
-import qualified Ldap.Client as Ldap
+
+import qualified Data.ByteString as ByteString
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import qualified Data.ByteString as ByteString
-import qualified Data.Set as Set
-import qualified Data.Map as Map
 import qualified Data.UUID as UUID
 
+import Foundation.Authorization (AuthorizationCacheKey(..))
+import Foundation.I18n
+import Foundation.Type
+import Foundation.Types
+
+import Handler.Utils.LdapSystemFunctions
+import Handler.Utils.Memcached
+import Handler.Utils.Profile
+
+import qualified Ldap.Client as Ldap
+
+import Yesod.Auth.Message
+
 
 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
-                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
+                , YesodAuth UniWorX, UserAuthId ~ AuthId UniWorX
                 )
-             => Creds UniWorX -> m (AuthenticationResult UniWorX)
+             => Creds UniWorX
+             -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
   $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
 
   now <- liftIO getCurrentTime
+  userAuthConf <- getsYesod $ view _appUserAuthConf
 
   let
-    uAuth = UniqueAuthentication $ CI.mk credsIdent
+    uAuth = UniqueExternalAuth $ CI.mk credsIdent
     upsertMode = creds ^? _upsertUserMode
 
     isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
@@ -68,46 +73,47 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       = return res
 
     excHandlers =
-      [ C.Handler $ \case
-          CampusUserNoResult -> do
-            $logWarnS "Auth" $ "User lookup failed after successful login for " <> credsIdent
+      [ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of
+          LdapUserNoResult -> do
+            $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
-          CampusUserAmbiguous -> do
-            $logWarnS "Auth" $ "Multiple auth results for " <> credsIdent
+          LdapUserAmbiguous -> do
+            $logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           err -> do
             $logErrorS "Auth" $ tshow err
             mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLdapError
-      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
+            excRecovery . ServerError $ mr MsgInternalLoginError
+      -- TODO: handle azure exceptions or generalize LdapUserException
+      , C.Handler $ \(cExc :: UserConversionException) -> do
           $logErrorS "Auth" $ tshow cExc
           mr <- getMessageRender
           excRecovery . ServerError $ mr cExc
       ]
 
+    -- | Authenticate already existing ExternalUser entries only
     acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
     acceptExisting = do
       res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
       case res of
-        Authenticated uid
-          -> associateUserSchoolsByTerms uid
+        Authenticated euid
+          -> associateUserSchoolsByTerms euid
         _other
           -> return ()
       case res of
         Authenticated uid
-          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
+          | not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ]
         _other -> return res
 
-  $logDebugS "auth" $ tshow Creds{..}
+  $logDebugS "Auth" $ tshow Creds{..}
 
-  userSourceConf <- getsYesod $ view _appUserSourceConf
-  flip catches excHandlers $ case userSourceConf of
-    UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf)
+  flip catches excHandlers $ case userAuthConf of
+    UserAuthConfSingleSource (AuthSourceConfAzureAdV2 azureConf)
       | Just upsertMode' <- upsertMode -> do
           azureData <- azureUser azureConf Creds{..}
           $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
           Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
-    UserSourceConfSingleSource (UserSourceLdap _)
+    UserAuthConfSingleSource (AuthSourceConfLdap _)
       | Just upsertMode' <- upsertMode -> do
           ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
           ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
@@ -117,16 +123,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       -> acceptExisting
 
 
-data CampusUserConversionException
-  = CampusUserInvalidIdent
-  | CampusUserInvalidEmail
-  | CampusUserInvalidDisplayName
-  | CampusUserInvalidGivenName
-  | CampusUserInvalidSurname
-  | CampusUserInvalidTitle
-  -- | CampusUserInvalidMatriculation
-  | CampusUserInvalidFeaturesOfStudy Text
-  | CampusUserInvalidAssociatedSchools Text
+data UserConversionException
+  = UserInvalidIdent
+  | UserInvalidEmail
+  | UserInvalidDisplayName
+  | UserInvalidGivenName
+  | UserInvalidSurname
+  | UserInvalidTitle
+  | UserInvalidFeaturesOfStudy Text
+  | UserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Exception)
 
@@ -138,17 +143,17 @@ _upsertUserMode mMode cs@Creds{..}
   | credsPlugin == apLdap  = setMode <$> mMode  UpsertUserLoginLdap
   | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
   where
-    setMode UpsertUserLoginAzure
+    setMode UpsertUserLoginAzure{} -- TODO: stuff upsertUserSource into credsExtra?
       = cs{ credsPlugin = apAzure }
-    setMode UpsertUserLoginLdap
+    setMode UpsertUserLoginLdap{} -- TODO: stuff upsertUserSource into credsExtra?
       = cs{ credsPlugin = apLdap }
-    setMode (UpsertUserLoginDummy ident)
+    setMode UpsertUserLoginDummy{..}
       = cs{ credsPlugin = apDummy
-          , credsIdent  = CI.original ident
+          , credsIdent  = CI.original upsertUserIdent
           }
-    setMode (UpsertUserLoginOther ident)
-      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
-          , credsIdent  = CI.original ident
+    setMode UpsertUserLoginOther{..}
+      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
+          , credsIdent  = CI.original upsertUserIdent
           }
     setMode _ = cs
 
@@ -165,27 +170,29 @@ ldapLookupAndUpsert :: forall m.
                     -> SqlPersistT m (Entity User)
 ldapLookupAndUpsert ident = 
   getsYesod (view _appLdapPool) >>= \case 
-    Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
+    Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
     Just ldapPool ->
       ldapUser'' ldapPool ident >>= \case
-        Nothing -> throwM CampusUserNoResult
+        Nothing -> throwM LdapUserNoResult
         Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
 
 
--- | Upsert User DB according to given LDAP data (does not query LDAP itself)
-upsertLdapUser :: forall m.
-                    ( MonadHandler m, HandlerSite m ~ UniWorX
-                    , MonadCatch m
-                    )
-                 => UpsertUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
-upsertLdapUser upsertMode ldapData = do
+-- | Upsert ExternalUser DB according to given external source data (does not query source itself)
+upsertUser :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  )
+               => UpsertUserMode
+               -> SqlPersistT m (Entity ExternalAuth)
+upsertUser upsertMode = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
   (newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData
   --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
-  oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
+  oldUsers <- selectKeysList [ ExternalUserIdent ==. externalUserIdent newUser ] []
 
   user@(Entity userId userRec) <- case oldUsers of
     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
@@ -220,55 +227,56 @@ upsertLdapUser upsertMode ldapData = do
   return user
 
 -- | Upsert User DB according to given Azure data (does not query Azure itself)
--- TODO: maybe merge with upsertLdapUser
-upsertAzureUser :: forall m.
-                    ( MonadHandler m, HandlerSite m ~ UniWorX
-                    , MonadCatch m
-                    )
-                 => UpsertUserMode -> [(Text, [ByteString])] -> SqlPersistT m (Entity User)
-upsertAzureUser upsertMode azureData = do
-  now <- liftIO getCurrentTime
-  userDefaultConf <- getsYesod $ view _appUserDefaults
-
-  (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
-  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
-
-  oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
-
-  user@(Entity userId userRec) <- case oldUsers of
-    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-  unless (validDisplayName (newUser ^. _userTitle)
-                           (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname)
-                           (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
-  when (validEmail' (userRec ^. _userEmail)) $ do
-    let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
-              ++ [ UserAuthentication =. AuthAzure                | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-    unless (null emUps) $ update userId emUps
-    -- Attempt to update ident, too:
-    unless (validEmail' (userRec ^. _userIdent)) $
-      void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
-
-  let
-    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-    userSystemFunctions' = do
-      (_k, v) <- azureData
-      -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
-      v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
-      assertM' (not . Text.null) $ Text.strip str
-
-  iforM_ userSystemFunctions $ \func preset -> do
-    memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
-    if | preset -> void $ upsert (UserSystemFunction userId func False False) []
-       | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
-
-  return user
+-- upsertAzureUser :: forall m.
+--                     ( MonadHandler m, HandlerSite m ~ UniWorX
+--                     , MonadCatch m
+--                     )
+--                  => UpsertUserMode
+--                  -> [(Text, [ByteString])]
+--                  -> SqlPersistT m (Entity User)
+-- upsertAzureUser upsertMode azureData = do
+--   now <- liftIO getCurrentTime
+--   userDefaultConf <- getsYesod $ view _appUserDefaults
+-- 
+--   (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
+--   --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
+-- 
+--   oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
+-- 
+--   user@(Entity userId userRec) <- case oldUsers of
+--     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
+--     _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
+--   unless (validDisplayName (newUser ^. _userTitle)
+--                            (newUser ^. _userFirstName)
+--                            (newUser ^. _userSurname)
+--                            (userRec ^. _userDisplayName)) $
+--     update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
+--   when (validEmail' (userRec ^. _userEmail)) $ do
+--     let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
+--               ++ [ UserAuthentication =. AuthAzure                | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
+--     unless (null emUps) $ update userId emUps
+--     -- Attempt to update ident, too:
+--     unless (validEmail' (userRec ^. _userIdent)) $
+--       void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
+-- 
+--   let
+--     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
+--     userSystemFunctions' = do
+--       (_k, v) <- azureData
+--       -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
+--       v' <- v
+--       Right str <- return $ Text.decodeUtf8' v'
+--       assertM' (not . Text.null) $ Text.strip str
+-- 
+--   iforM_ userSystemFunctions $ \func preset -> do
+--     memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
+--     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
+--        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
+-- 
+--   return user
 
 decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
-        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
+        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either UserConversionException (User, [Update User]))
 decodeLdapUserTest mbIdent ldapData = do
     now <- liftIO getCurrentTime
     userDefaultConf <- getsYesod $ view _appUserDefaults
@@ -276,107 +284,46 @@ decodeLdapUserTest mbIdent ldapData = do
     try $ decodeLdapUser now userDefaultConf mode ldapData
 
 decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
-        => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either CampusUserConversionException (User, [Update User]))
+        => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either UserConversionException (User, [Update User]))
 decodeAzureUserTest mbIdent azureData = do
     now <- liftIO getCurrentTime
     userDefaultConf <- getsYesod $ view _appUserDefaults
     let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
     try $ decodeAzureUser now userDefaultConf mode azureData
 
-decodeLdapUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
-decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
-    let
-      userTelephone             = decodeLdap ldapUserTelephone
-      userMobile                = decodeLdap ldapUserMobile
-      userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
-      userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
-
-      userAuthentication
-        | is _UpsertUserLoginOther upsertMode
-                    = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
-        | otherwise = AuthLDAP
-      userLastAuthentication = guardOn isLogin now
-      isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
-
-      userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
-      userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
-      userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
-    userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
-
-    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
-
-    userIdent <- if
-      | [bs] <- ldapMap !!! ldapUserPrincipalName
-      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-      , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
-        -> return userIdent'
-      | Just userIdent' <- upsertMode ^? _upsertUserIdent
-        -> return userIdent'
-      | otherwise
-        -> throwM CampusUserInvalidIdent
-
-    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
-      --   | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
-      --      -> return $ CI.mk userEmail
-      | otherwise
-        -> throwM CampusUserInvalidEmail
-        
-    userLdapPrimaryKey <- if
+decodeLdapUser :: ( MonadThrow m
+                  )
+               => UTCTime -- ^ Now
+               -> UpsertUserMode
+               -> Ldap.AttrList [] -- ^ Raw LDAP data
+               -> m (ExternalAuth,_) -- ^ Data for new ExternalUser entry and updating existing ExternalUser entry
+decodeLdapUser now upsertMode ldapData = do
+    externalAuthIdent <- if
       | [bs] <- ldapMap !!! ldapPrimaryKey
-      , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
-      , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-        -> return $ Just userLdapPrimaryKey'''
+      , Right ldapPrimaryKey' <- Text.decodeUtf8' bs
+      , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
+        -> return ldapPrimaryKey''
       | otherwise
-        -> return Nothing
+        -> throwM ExternalUserInvalidIdent
+
+    let externalAuthData = encode ldapData
+
+    externalAuthLastAuth <- if
+      | is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode
+        -> Nothing
+      | otherwise
+        -> Just now
 
     let
-      newUser = User
-        { userMaxFavourites           = userDefaultMaxFavourites
-        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-        , userTheme                   = userDefaultTheme
-        , userDateTimeFormat          = userDefaultDateTimeFormat
-        , userDateFormat              = userDefaultDateFormat
-        , userTimeFormat              = userDefaultTimeFormat
-        , userDownloadFiles           = userDefaultDownloadFiles
-        , userWarningDays             = userDefaultWarningDays
-        , userShowSex                 = userDefaultShowSex
-        , userSex                     = Nothing
-        , userBirthday                = Nothing
-        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-        , userNotificationSettings    = def
-        , userLanguages               = Nothing
-        , userCsvOptions              = def
-        , userTokensIssuedAfter       = Nothing
-        , userCreated                 = now
-        , userLastLdapSynchronisation = Just now
-        , userAzurePrimaryKey         = Nothing
-        , userLastAzureSynchronisation = Nothing
-        , userDisplayName             = userDisplayName
-        , userDisplayEmail            = userEmail
-        , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-        , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-        , userPostLastUpdate          = Nothing
-        , userPinPassword             = Nothing -- must be derived via AVS
-        , userPrefersPostal           = userDefaultPrefersPostal
+      newUser = ExternalAuth
+        { externalAuthSource   =  ldapSourceIdent
+        , externalAuthLastSync =  now
         , ..
         }
-      userUpdate =  
-        [ UserLastAuthentication      =. Just now  | isLogin ] ++
-        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
-        [
-        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
-          UserFirstName               =. userFirstName
-        , UserSurname                 =. userSurname                    
-        , UserLastLdapSynchronisation =. Just now
-        , UserLdapPrimaryKey          =. userLdapPrimaryKey
-        , UserMobile                  =. userMobile
-        , UserTelephone               =. userTelephone
-        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-        , UserCompanyDepartment       =. userCompanyDepartment
+      userUpdate =
+        [ ExternalAuthIdent    =. externalAuthIdent
+        , ExternalAuthData     =. externalAuthData
+        , ExternalAuthLastSync =. now
         ]
     return (newUser, userUpdate)
 
@@ -414,6 +361,133 @@ decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
     --     | otherwise = throwM err
     --   where
     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+-- decodeLdapUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
+-- decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
+--     let
+--       userTelephone             = decodeLdap ldapUserTelephone
+--       userMobile                = decodeLdap ldapUserMobile
+--       userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
+--       userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
+-- 
+--       userAuthentication
+--         | is _UpsertUserLoginOther upsertMode
+--                     = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
+--         | otherwise = AuthLDAP
+--       userLastAuthentication = guardOn isLogin now
+--       isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
+-- 
+--       userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
+--       userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
+--       userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
+--     userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+-- 
+--     --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
+--     -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
+-- 
+--     userIdent <- if
+--       | [bs] <- ldapMap !!! ldapUserPrincipalName
+--       , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+--       , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
+--         -> return userIdent'
+--       | Just userIdent' <- upsertMode ^? _upsertUserIdent
+--         -> return userIdent'
+--       | otherwise
+--         -> throwM CampusUserInvalidIdent
+-- 
+--     userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
+--       --   | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
+--       --      -> return $ CI.mk userEmail
+--       | otherwise
+--         -> throwM CampusUserInvalidEmail
+--         
+--     -- TODO: ExternalUser
+--     userLdapPrimaryKey <- if
+--       | [bs] <- ldapMap !!! ldapPrimaryKey
+--       , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
+--       , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
+--         -> return $ Just userLdapPrimaryKey'''
+--       | otherwise
+--         -> return Nothing
+-- 
+--     let
+--       newUser = User
+--         { userMaxFavourites           = userDefaultMaxFavourites
+--         , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+--         , userTheme                   = userDefaultTheme
+--         , userDateTimeFormat          = userDefaultDateTimeFormat
+--         , userDateFormat              = userDefaultDateFormat
+--         , userTimeFormat              = userDefaultTimeFormat
+--         , userDownloadFiles           = userDefaultDownloadFiles
+--         , userWarningDays             = userDefaultWarningDays
+--         , userShowSex                 = userDefaultShowSex
+--         , userSex                     = Nothing
+--         , userBirthday                = Nothing
+--         , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+--         , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+--         , userNotificationSettings    = def
+--         , userLanguages               = Nothing
+--         , userCsvOptions              = def
+--         , userTokensIssuedAfter       = Nothing
+--         , userCreated                 = now
+--         , userDisplayName             = userDisplayName
+--         , userDisplayEmail            = userEmail
+--         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+--         , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+--         , userPostLastUpdate          = Nothing
+--         , userPinPassword             = Nothing -- must be derived via AVS
+--         , userPrefersPostal           = userDefaultPrefersPostal
+--         , ..
+--         }
+--       userUpdate =  
+--         [ UserLastAuthentication      =. Just now  | isLogin ] ++
+--         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
+--         [
+--         -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
+--           UserFirstName               =. userFirstName
+--         , UserSurname                 =. userSurname                    
+--         , UserMobile                  =. userMobile
+--         , UserTelephone               =. userTelephone
+--         , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+--         , UserCompanyDepartment       =. userCompanyDepartment
+--         ]
+--     return (newUser, userUpdate)
+-- 
+--   where
+--     ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
+--     ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
+-- 
+--     -- just returns Nothing on error, pure
+--     decodeLdap :: Ldap.Attr -> Maybe Text
+--     decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
+-- 
+--     decodeLdap' :: Ldap.Attr -> Text
+--     decodeLdap' = fromMaybe "" . decodeLdap
+--     -- accept the first successful decoding or empty; only throw an error if all decodings fail
+--     -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
+--     -- decodeLdap' attr err
+--     --     | []    <-        vs = return   Nothing
+--     --     | (h:_) <- rights vs = return $ Just h
+--     --     | otherwise          = throwM err
+--     --   where
+--     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+-- 
+--     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
+--     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
+--     decodeLdap1 attr err
+--         | (h:_) <- rights vs  = return h
+--         | otherwise           = throwM err
+--       where
+--         vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+-- 
+--     -- accept and merge one or more successful decodings, ignoring all others
+--     -- decodeLdapN attr err
+--     --     | t@(_:_) <- rights vs
+--     --       = return $ Text.unwords t
+--     --     | otherwise = throwM err
+--     --   where
+--     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
 decodeAzureUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
 decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
@@ -433,7 +507,7 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
       userTitle       = Nothing -- TODO decodeAzure  ldapUserTitle     -- CampusUserInvalidTitle
       userFirstName   = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
       userSurname     = decodeAzure' azureUserSurname   -- CampusUserInvalidSurname
-    userDisplayName <- decodeAzure1  azureUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+    userDisplayName <- decodeAzure1  azureUserDisplayName  UserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
 
     --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
     -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
@@ -446,14 +520,14 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
       | Just userIdent' <- upsertMode ^? _upsertUserIdent
         -> return userIdent'
       | otherwise
-        -> throwM CampusUserInvalidIdent
+        -> throwM UserInvalidIdent
 
     userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
       --      -> return $ CI.mk userEmail
       | otherwise
-        -> throwM CampusUserInvalidEmail
+        -> throwM UserInvalidEmail
         
     -- TODO: use fromASCIIBytes / fromByteString?
     userAzurePrimaryKey <- if
@@ -485,9 +559,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
         , userCsvOptions              = def
         , userTokensIssuedAfter       = Nothing
         , userCreated                 = now
-        , userLastAzureSynchronisation = Just now
-        , userLdapPrimaryKey          = Nothing
-        , userLastLdapSynchronisation = Nothing
         , userDisplayName             = userDisplayName
         , userDisplayEmail            = userEmail
         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
@@ -504,8 +575,6 @@ decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
         -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
           UserFirstName               =. userFirstName
         , UserSurname                 =. userSurname
-        , UserLastAzureSynchronisation =. Just now
-        , UserAzurePrimaryKey          =. userAzurePrimaryKey
         , UserMobile                  =. userMobile
         , UserTelephone               =. userTelephone
         , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
@@ -582,4 +651,4 @@ updateUserLanguage Nothing = runMaybeT $ do
   setRegisteredCookie CookieLang lang
   return lang
 
-embedRenderMessage ''UniWorX ''CampusUserConversionException id
+embedRenderMessage ''UniWorX ''UserConversionException id

From bf13473954641284449ecb3348c41b8d9de5ee9e Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 18 Feb 2024 05:06:23 +0100
Subject: [PATCH 082/178] chore(auth): rewrote authenticate (still WIP)

---
 models/auth.model            |   4 +-
 src/Foundation/Instances.hs  |   2 +-
 src/Foundation/Types.hs      |  45 ++--
 src/Foundation/Yesod/Auth.hs | 508 ++++++++++++++++++++---------------
 4 files changed, 321 insertions(+), 238 deletions(-)

diff --git a/models/auth.model b/models/auth.model
index 69d0502b0..147fefa9b 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -34,8 +34,8 @@ AuthSourceLdap
 -- | User authentication data, source-agnostic data
 UserAuth
     ident     UserIdent                    -- Human-readable text uniquely identifying a user
-    lastLogin UTCTime                      -- When did the corresponding User last authenticate using this entry?
-    lastSync  UTCTime Maybe                -- When was the corresponding User entry last synced with any external source? -- TODO rethink
+    lastLogin UTCTime Maybe                -- When did the corresponding User last authenticate using this entry?
+    lastSync  UTCTime Maybe                -- When was the corresponding User entry last synced with any external source?
     Primary ident
     UniqueAuthentication ident
     deriving Show Eq Ord Generic
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index a076b389e..9a8c15327 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -172,7 +172,7 @@ instance YesodAuth UniWorX where
               BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
               hoistMaybe bearerImpersonate
 
--- TODO: update?
+-- TODO: update to new AuthId!
 instance YesodAuthPersist UniWorX where
   getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
   getAuthEntity = liftHandler . runDBRead . get
diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs
index 0a2a4a97a..0cb2f2234 100644
--- a/src/Foundation/Types.hs
+++ b/src/Foundation/Types.hs
@@ -4,8 +4,11 @@
 
 module Foundation.Types
   ( UpsertUserMode(..)
-  , _UpsertUserLoginLdap, _UpsertUserLoginAzure, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
-  , _upsertUserLdapSource, _upsertUserLdapData, _upsertUserAzureSource, _upsertUserAzureData, _upsertUserIdent
+  , _UpsertUserLogin, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
+  , _upsertUserSource, _upsertUserIdent
+  , UpsertUserData(..)
+  , _UpsertUserDataAzure, _UpsertUserDataLdap
+  , _upsertUserAzureConf, _upsertUserAzureData, _upsertUserLdapConf, _upsertUserLdapData
   ) where
 
 import Import.NoFoundation
@@ -14,25 +17,27 @@ import qualified Ldap.Client as Ldap
 
 
 data UpsertUserMode
-  = UpsertUserLoginLdap
-    { upsertUserLdapSource  :: AuthSourceLdapId
-    , upsertUserLdapData    :: Ldap.AttrList []
-    }
-  | UpsertUserLoginAzure
-    { upsertUserAzureSource :: AuthSourceAzureId
-    , upsertUserAzureData   :: [(Text, [ByteString])]  -- TODO: use type synonym?
-    }
-  | UpsertUserLoginDummy
-    { upsertUserIdent       :: UserIdent
-    }
-  | UpsertUserLoginOther  -- does not allow further login
-    { upsertUserIdent       :: UserIdent
-    }
-  | UpsertUserSync
-    { upsertUserIdent       :: UserIdent
-    }
+  = UpsertUserLogin      { upsertUserSource :: Text } -- TODO: use type synonym?
+  | UpsertUserLoginDummy { upsertUserIdent  :: UserIdent }
+  | UpsertUserLoginOther { upsertUserIdent  :: UserIdent } -- does not allow further login
+  | UpsertUserSync       { upsertUserIdent  :: UserIdent }
   | UpsertUserGuessUser
-  deriving (Eq, Ord, Read, Show, Generic)
+  deriving (Show)
 
 makeLenses_ ''UpsertUserMode
 makePrisms ''UpsertUserMode
+
+
+data UpsertUserData
+  = UpsertUserDataAzure
+    { upsertUserAzureConf :: AzureConf
+    , upsertUserAzureData :: [(Text, [ByteString])]  -- TODO: use type synonym?
+    }
+  | UpsertUserDataLdap
+    { upsertUserLdapConf  :: LdapConf
+    , upsertUserLdapData  :: Ldap.AttrList []
+    }
+  deriving (Show)
+
+makeLenses_ ''UpsertUserData
+makePrisms ''UpsertUserData
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index b43320fbd..feeb1c692 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -4,9 +4,9 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , ldapLookupAndUpsert
+  , ldapLookupAndUpsert -- TODO generalize
   , upsertUser
-  , decodeLdapUserTest, decodeAzureUserTest
+  , decodeUserTest
   , UserConversionException(..)
   , updateUserLanguage
   ) where
@@ -20,13 +20,13 @@ import Auth.PWHash (apHash)
 
 import qualified Control.Monad.Catch as C (Handler(..))
 
+-- import qualified Data.Aeson as Json (encode)
 import qualified Data.ByteString as ByteString
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import qualified Data.UUID as UUID
 
 import Foundation.Authorization (AuthorizationCacheKey(..))
 import Foundation.I18n
@@ -55,7 +55,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
   userAuthConf <- getsYesod $ view _appUserAuthConf
 
   let
-    uAuth = UniqueExternalAuth $ CI.mk credsIdent
+    uAuth = UniqueAuthentication $ CI.mk credsIdent
     upsertMode = creds ^? _upsertUserMode
 
     isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
@@ -96,29 +96,29 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
     acceptExisting = do
       res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
       case res of
-        Authenticated euid
-          -> associateUserSchoolsByTerms euid
+        Authenticated uid
+          -> associateUserSchoolsByTerms uid
         _other
           -> return ()
       case res of
         Authenticated uid
-          | not isDummy -> res <$ update euid [ ExternalUserLastAuth =. Just now ]
+          | not isDummy -> res <$ update uid [ UserAuthLastLogin =. Just now ]
         _other -> return res
 
   $logDebugS "Auth" $ tshow Creds{..}
 
   flip catches excHandlers $ case userAuthConf of
-    UserAuthConfSingleSource (AuthSourceConfAzureAdV2 azureConf)
+    UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf)
       | Just upsertMode' <- upsertMode -> do
-          azureData <- azureUser azureConf Creds{..}
-          $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow azureData
-          Authenticated . entityKey <$> upsertAzureUser upsertMode' azureData
-    UserAuthConfSingleSource (AuthSourceConfLdap _)
+          upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
+          $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
+          Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
+    UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf)
       | Just upsertMode' <- upsertMode -> do
           ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-          ldapData <- ldapUser ldapPool Creds{..} -- ldapUserWith withLdap ldapPool FailoverNone Creds{..}
-          $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-          Authenticated . entityKey <$> upsertLdapUser upsertMode' ldapData
+          upsertUserLdapData <- ldapUser ldapPool Creds{..}
+          $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
+          Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
     _other
       -> acceptExisting
 
@@ -136,17 +136,16 @@ data UserConversionException
   deriving anyclass (Exception)
 
 
+-- TODO: this is probably not a sane traversal anymore...
 _upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
 _upsertUserMode mMode cs@Creds{..}
   | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
-  | credsPlugin == apAzure = setMode <$> mMode  UpsertUserLoginAzure
-  | credsPlugin == apLdap  = setMode <$> mMode  UpsertUserLoginLdap
+  | credsPlugin `elem` loginAPs
+                           = setMode <$> mMode (UpsertUserLogin credsPlugin)
   | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
   where
-    setMode UpsertUserLoginAzure{} -- TODO: stuff upsertUserSource into credsExtra?
-      = cs{ credsPlugin = apAzure }
-    setMode UpsertUserLoginLdap{} -- TODO: stuff upsertUserSource into credsExtra?
-      = cs{ credsPlugin = apLdap }
+    setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
+      = cs{ credsPlugin = upsertUserSource }
     setMode UpsertUserLoginDummy{..}
       = cs{ credsPlugin = apDummy
           , credsIdent  = CI.original upsertUserIdent
@@ -157,9 +156,11 @@ _upsertUserMode mMode cs@Creds{..}
           }
     setMode _ = cs
 
+    loginAPs = [ apAzure, apLdap ]
     defaultOther = apHash
 
 
+-- TODO: generalize
 ldapLookupAndUpsert :: forall m.
                        ( MonadHandler m
                        , HandlerSite m ~ UniWorX
@@ -167,64 +168,84 @@ ldapLookupAndUpsert :: forall m.
                        , MonadUnliftIO m
                        )
                     => Text
-                    -> SqlPersistT m (Entity User)
+                    -> SqlPersistT m (Entity UserAuth)
 ldapLookupAndUpsert ident = 
   getsYesod (view _appLdapPool) >>= \case 
     Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
-    Just ldapPool ->
+    Just ldapPool@(upsertUserLdapConf, _) ->
       ldapUser'' ldapPool ident >>= \case
         Nothing -> throwM LdapUserNoResult
-        Just ldapResponse -> upsertLdapUser UpsertUserGuessUser ldapResponse
+        Just upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}
 
 
--- | Upsert ExternalUser DB according to given external source data (does not query source itself)
+-- | Upsert User and related auth in DB according to given external source data (does not query source itself)
 upsertUser :: forall m.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , MonadCatch m
                   )
                => UpsertUserMode
-               -> SqlPersistT m (Entity ExternalAuth)
-upsertUser upsertMode = do
+               -> UpsertUserData
+               -> SqlPersistT m (Entity UserAuth)
+upsertUser upsertMode upsertData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
-  (newUser,userUpdate) <- decodeLdapUser now userDefaultConf upsertMode ldapData
+  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertData
   --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
-  oldUsers <- selectKeysList [ ExternalUserIdent ==. externalUserIdent newUser ] []
+  oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
 
-  user@(Entity userId userRec) <- case oldUsers of
-    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-  unless (validDisplayName (newUser ^. _userTitle) 
+  _user@(Entity userId userRec) <- case oldUsers of
+    [oldUserId] -> updateGetEntity oldUserId userUpdate
+    _other      -> upsertBy (UniqueUser (newUser ^. _userIdent)) newUser userUpdate
+
+  -- sets display name
+  -- TODO: use display name from external source, if possible
+  unless (validDisplayName (newUser ^. _userTitle)
                            (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname) 
+                           (newUser ^. _userSurname)
                            (userRec ^. _userDisplayName)) $
     update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
-  when (validEmail' (userRec ^. _userEmail)) $ do 
-    let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
-              ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-    unless (null emUps) $ update userId emUps
-    -- Attempt to update ident, too:
-    unless (validEmail' (userRec ^. _userIdent)) $
-      void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
+
+  -- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure)
+  -- when (validEmail' (userRec ^. _userEmail)) $ do
+  --   let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
+  --             ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
+  --   unless (null emUps) $ update userId emUps
+  --   -- Attempt to update ident, too:
+  --   unless (validEmail' (userRec ^. _userIdent)) $
+  --     void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
 
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-    userSystemFunctions' = do
-      (k, v) <- ldapData
-      guard $ k == ldapAffiliation
-      v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
-      assertM' (not . Text.null) $ Text.strip str
+    userSystemFunctions' = case upsertData of
+      UpsertUserDataAzure{..} -> do
+        (_k, v) <- upsertUserAzureData
+        v' <- v
+        Right str <- return $ Text.decodeUtf8' v'
+        assertM' (not . Text.null) $ Text.strip str
+      UpsertUserDataLdap{..} -> do
+        (k, v) <- upsertUserLdapData
+        guard $ k == ldapAffiliation
+        v' <- v
+        Right str <- return $ Text.decodeUtf8' v'
+        assertM' (not . Text.null) $ Text.strip str
 
   iforM_ userSystemFunctions $ \func preset -> do
     memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  return user
+  let (userAuthLastLogin, userAuthLastSync) = case upsertMode of
+        UpsertUserSync{}      -> (Nothing , Just now)
+        UpsertUserGuessUser{} -> (Nothing , Nothing )
+        _other                -> (Just now, Nothing )
+  userAuth <- upsertBy (UniqueAuthentication $ newUser ^. _userIdent) UserAuth{ userAuthIdent = newUser ^. _userIdent, ..} $
+    [ UserAuthLastLogin =. Just lastLogin | lastLogin <- maybeToList userAuthLastLogin ] ++
+    [ UserAuthLastSync  =. Just lastSync  | lastSync  <- maybeToList userAuthLastSync  ]
+
+  return userAuth
 
 -- | Upsert User DB according to given Azure data (does not query Azure itself)
 -- upsertAzureUser :: forall m.
@@ -275,68 +296,122 @@ upsertUser upsertMode = do
 -- 
 --   return user
 
-decodeLdapUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
-        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either UserConversionException (User, [Update User]))
-decodeLdapUserTest mbIdent ldapData = do
-    now <- liftIO getCurrentTime
-    userDefaultConf <- getsYesod $ view _appUserDefaults
-    let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
-    try $ decodeLdapUser now userDefaultConf mode ldapData
-
-decodeAzureUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
-        => Maybe UserIdent -> [(Text, [ByteString])] -> m (Either UserConversionException (User, [Update User]))
-decodeAzureUserTest mbIdent azureData = do
-    now <- liftIO getCurrentTime
-    userDefaultConf <- getsYesod $ view _appUserDefaults
-    let mode = maybe UpsertUserLoginLdap UpsertUserLoginDummy mbIdent
-    try $ decodeAzureUser now userDefaultConf mode azureData
-
-decodeLdapUser :: ( MonadThrow m
+decodeUserTest :: ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
                   )
-               => UTCTime -- ^ Now
-               -> UpsertUserMode
-               -> Ldap.AttrList [] -- ^ Raw LDAP data
-               -> m (ExternalAuth,_) -- ^ Data for new ExternalUser entry and updating existing ExternalUser entry
-decodeLdapUser now upsertMode ldapData = do
-    externalAuthIdent <- if
-      | [bs] <- ldapMap !!! ldapPrimaryKey
-      , Right ldapPrimaryKey' <- Text.decodeUtf8' bs
+               => UpsertUserData
+               -> m (Either UserConversionException (User, [Update User]))
+decodeUserTest decodeData = do
+  now <- liftIO getCurrentTime
+  userDefaultConf <- getsYesod $ view _appUserDefaults
+  try $ decodeUser now userDefaultConf decodeData
+
+decodeUser :: ( MonadThrow m
+              )
+           => UTCTime -- ^ Now
+           -> UserDefaultConf
+           -> UpsertUserData -- ^ Raw source data
+           -> m (User,_) -- ^ Data for new User entry and updating existing User entries
+decodeUser now UserDefaultConf{..} upsertData = do
+    userIdent <- if
+      | Just azureData <- mbAzureData
+      , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
+      , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
+        -> return $ CI.mk azureUserPrincipalName''
+      | Just ldapData <- mbLdapData
+      , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
       , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
-        -> return ldapPrimaryKey''
+        -> return $ CI.mk ldapPrimaryKey''
       | otherwise
-        -> throwM ExternalUserInvalidIdent
-
-    let externalAuthData = encode ldapData
-
-    externalAuthLastAuth <- if
-      | is _UpsertUserSync upsertMode || is _UpsertUserGuessUser upsertMode
-        -> Nothing
-      | otherwise
-        -> Just now
+        -> throwM UserInvalidIdent
 
     let
-      newUser = ExternalAuth
-        { externalAuthSource   =  ldapSourceIdent
-        , externalAuthLastSync =  now
+      (userSurname, userFirstName, userDisplayName, userEmail, userTelephone, userMobile, userCompanyPersonalNumber, userCompanyDepartment, userLanguages)
+        | Just azureData <- mbAzureData
+          = ( azureData `decodeAzure'` azureUserSurname
+            , azureData `decodeAzure'` azureUserGivenName
+            , azureData `decodeAzure'` azureUserDisplayName
+            , CI.mk $
+              azureData `decodeAzure'` azureUserMail
+            , azureData `decodeAzure`  azureUserTelephone
+            , azureData `decodeAzure`  azureUserMobile
+            , Nothing -- userCompanyPersonalNumber not contained in Azure response
+            , Nothing -- userCompanyDepartment not contained in Azure response
+            , Nothing -- azureData `decodeAzure`  azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
+            )
+        | Just ldapData <- mbLdapData
+          = ( ldapData `decodeLdap'` ldapUserSurname
+            , ldapData `decodeLdap'` ldapUserFirstName
+            , ldapData `decodeLdap'` ldapUserDisplayName
+            , CI.mk $
+              ldapData `decodeLdap'` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
+            , ldapData `decodeLdap`  ldapUserTelephone
+            , ldapData `decodeLdap`  ldapUserMobile
+            , ldapData `decodeLdap`  ldapUserFraportPersonalnummer
+            , ldapData `decodeLdap`  ldapUserFraportAbteilung
+            , Nothing -- userLanguage not contained in LDAP response
+            )
+        | otherwise
+          = error "decodeUser: Both azureData and ldapData are empty, cannot decode basic fields from no data!"
+
+    let
+      newUser = User
+        { userMaxFavourites         =  userDefaultMaxFavourites
+        , userMaxFavouriteTerms     =  userDefaultMaxFavouriteTerms
+        , userTheme                 =  userDefaultTheme
+        , userDateTimeFormat        =  userDefaultDateTimeFormat
+        , userDateFormat            =  userDefaultDateFormat
+        , userTimeFormat            =  userDefaultTimeFormat
+        , userDownloadFiles         =  userDefaultDownloadFiles
+        , userWarningDays           =  userDefaultWarningDays
+        , userShowSex               =  userDefaultShowSex
+        , userSex                   =  Nothing
+        , userBirthday              =  Nothing
+        , userTitle                 =  Nothing
+        , userExamOfficeGetSynced   =  userDefaultExamOfficeGetSynced
+        , userExamOfficeGetLabels   =  userDefaultExamOfficeGetLabels
+        , userNotificationSettings  =  def
+        , userCsvOptions            =  def
+        , userTokensIssuedAfter     =  Nothing
+        , userCreated               =  now
+        , userDisplayEmail          =  userEmail
+        , userMatrikelnummer        =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
+        , userPostAddress           =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
+        , userPostLastUpdate        =  Nothing
+        , userPinPassword           =  Nothing -- must be derived via AVS
+        , userPrefersPostal         =  userDefaultPrefersPostal
         , ..
         }
       userUpdate =
-        [ ExternalAuthIdent    =. externalAuthIdent
-        , ExternalAuthData     =. externalAuthData
-        , ExternalAuthLastSync =. now
+        [ UserSurname               =. userSurname
+        , UserFirstName             =. userFirstName
+     -- , UserDisplayName           =. userDisplayName -- not updated, since users are allowed to change their DisplayName
+        , UserEmail                 =. userEmail
+        , UserTelephone             =. userTelephone
+        , UserMobile                =. userMobile
+        , UserCompanyPersonalNumber =. userCompanyPersonalNumber
+        , UserCompanyDepartment     =. userCompanyDepartment
         ]
     return (newUser, userUpdate)
 
   where
-    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
-    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
+    mbAzureData :: Maybe (Map Text [ByteString])
+    mbAzureData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserAzureData upsertData
+    mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
+    mbLdapData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserLdapData upsertData
+    -- ldapData = fmap (Map.fromListWith (++)) $ upsertData ^? _upsertUserLdapData . over _2 (filter $ not . ByteString.null)
 
     -- just returns Nothing on error, pure
-    decodeLdap :: Ldap.Attr -> Maybe Text
-    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
+    decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
+    decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k
+    decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
+    decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
 
-    decodeLdap' :: Ldap.Attr -> Text
-    decodeLdap' = fromMaybe "" . decodeLdap
+    decodeAzure' :: Map Text [ByteString] -> Text -> Text
+    decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
+    decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
+    decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
     -- accept the first successful decoding or empty; only throw an error if all decodings fail
     -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
     -- decodeLdap' attr err
@@ -348,11 +423,11 @@ decodeLdapUser now upsertMode ldapData = do
 
     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    decodeLdap1 attr err
-        | (h:_) <- rights vs  = return h
-        | otherwise           = throwM err
-      where
-        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+    -- decodeLdap1 ldapData attr err
+    --     | (h:_) <- rights vs  = return h
+    --     | otherwise           = throwM err
+    --   where
+    --     vs = Text.decodeUtf8' <$> (ldapData !!! attr)
 
     -- accept and merge one or more successful decodings, ignoring all others
     -- decodeLdapN attr err
@@ -489,121 +564,122 @@ decodeLdapUser now upsertMode ldapData = do
 --     --   where
 --     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
-decodeAzureUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
-decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
-    let
-      userTelephone             = decodeAzure azureUserTelephone
-      userMobile                = decodeAzure azureUserMobile
-      userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer
-      userCompanyDepartment     = Nothing --TODO decodeAzure ldapUserFraportAbteilung
-
-      userAuthentication
-        | is _UpsertUserLoginOther upsertMode
-                    = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
-        | otherwise = AuthAzure
-      userLastAuthentication = guardOn isLogin now
-      isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode
-
-      userTitle       = Nothing -- TODO decodeAzure  ldapUserTitle     -- CampusUserInvalidTitle
-      userFirstName   = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
-      userSurname     = decodeAzure' azureUserSurname   -- CampusUserInvalidSurname
-    userDisplayName <- decodeAzure1  azureUserDisplayName  UserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
-
-    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
-
-    userIdent <- if
-      | [bs] <- azureMap !!! azureUserPrincipalName
-      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-      , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
-        -> return userIdent'
-      | Just userIdent' <- upsertMode ^? _upsertUserIdent
-        -> return userIdent'
-      | otherwise
-        -> throwM UserInvalidIdent
-
-    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
-      --      -> return $ CI.mk userEmail
-      | otherwise
-        -> throwM UserInvalidEmail
-        
-    -- TODO: use fromASCIIBytes / fromByteString?
-    userAzurePrimaryKey <- if
-      | [bs] <- azureMap !!! azurePrimaryKey
-      , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs
-      , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey''
-      , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey'''
-        -> return $ Just userAzurePrimaryKey''''
-      | otherwise
-        -> return Nothing
-
-    let
-      newUser = User
-        { userMaxFavourites           = userDefaultMaxFavourites
-        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-        , userTheme                   = userDefaultTheme
-        , userDateTimeFormat          = userDefaultDateTimeFormat
-        , userDateFormat              = userDefaultDateFormat
-        , userTimeFormat              = userDefaultTimeFormat
-        , userDownloadFiles           = userDefaultDownloadFiles
-        , userWarningDays             = userDefaultWarningDays
-        , userShowSex                 = userDefaultShowSex
-        , userSex                     = Nothing
-        , userBirthday                = Nothing
-        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-        , userNotificationSettings    = def
-        , userLanguages               = Nothing -- TODO: decode and parse preferredLanguages
-        , userCsvOptions              = def
-        , userTokensIssuedAfter       = Nothing
-        , userCreated                 = now
-        , userDisplayName             = userDisplayName
-        , userDisplayEmail            = userEmail
-        , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-        , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-        , userPostLastUpdate          = Nothing
-        , userPinPassword             = Nothing -- must be derived via AVS
-        , userPrefersPostal           = userDefaultPrefersPostal
-        , ..
-        }
-      userUpdate =  
-        [ UserLastAuthentication      =. Just now  | isLogin ] ++
-        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
-        [
-        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-          UserFirstName               =. userFirstName
-        , UserSurname                 =. userSurname
-        , UserMobile                  =. userMobile
-        , UserTelephone               =. userTelephone
-        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-        , UserCompanyDepartment       =. userCompanyDepartment
-        ]
-    return (newUser, userUpdate)
-
-  where
-    azureMap :: Map.Map Text [ByteString]
-    azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null))
-
-    -- just returns Nothing on error, pure
-    decodeAzure :: Text -> Maybe Text
-    decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr
-
-    decodeAzure' :: Text -> Text
-    decodeAzure' = fromMaybe "" . decodeAzure
-
-    -- only accepts the first successful decoding, ignoring all others, but failing if there is none
-    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    decodeAzure1 attr err
-        | (h:_) <- rights vs  = return h
-        | otherwise           = throwM err
-      where
-        vs = Text.decodeUtf8' <$> (azureMap !!! attr)
+-- decodeAzureUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
+-- decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
+--     let
+--       userTelephone             = decodeAzure azureUserTelephone
+--       userMobile                = decodeAzure azureUserMobile
+--       userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer
+--       userCompanyDepartment     = Nothing --TODO decodeAzure ldapUserFraportAbteilung
+-- 
+--       userAuthentication
+--         | is _UpsertUserLoginOther upsertMode
+--                     = AuthPWHash (error "Non-LDAP logins should only work for users that are already known") -- TODO throwM instead?
+--         | otherwise = AuthAzure
+--       userLastAuthentication = guardOn isLogin now
+--       isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode
+-- 
+--       userTitle       = Nothing -- TODO decodeAzure  ldapUserTitle     -- CampusUserInvalidTitle
+--       userFirstName   = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
+--       userSurname     = decodeAzure' azureUserSurname   -- CampusUserInvalidSurname
+--     userDisplayName <- decodeAzure1  azureUserDisplayName  UserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+-- 
+--     --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
+--     -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
+-- 
+--     userIdent <- if
+--       | [bs] <- azureMap !!! azureUserPrincipalName
+--       , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+--       , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
+--         -> return userIdent'
+--       | Just userIdent' <- upsertMode ^? _upsertUserIdent
+--         -> return userIdent'
+--       | otherwise
+--         -> throwM UserInvalidIdent
+-- 
+--     userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
+--       --      -> return $ CI.mk userEmail
+--       | otherwise
+--         -> throwM UserInvalidEmail
+--         
+--     -- TODO: use fromASCIIBytes / fromByteString?
+--     userAzurePrimaryKey <- if
+--       | [bs] <- azureMap !!! azurePrimaryKey
+--       , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs
+--       , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey''
+--       , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey'''
+--         -> return $ Just userAzurePrimaryKey''''
+--       | otherwise
+--         -> return Nothing
+-- 
+--     let
+--       newUser = User
+--         { userMaxFavourites           = userDefaultMaxFavourites
+--         , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+--         , userTheme                   = userDefaultTheme
+--         , userDateTimeFormat          = userDefaultDateTimeFormat
+--         , userDateFormat              = userDefaultDateFormat
+--         , userTimeFormat              = userDefaultTimeFormat
+--         , userDownloadFiles           = userDefaultDownloadFiles
+--         , userWarningDays             = userDefaultWarningDays
+--         , userShowSex                 = userDefaultShowSex
+--         , userSex                     = Nothing
+--         , userBirthday                = Nothing
+--         , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+--         , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+--         , userNotificationSettings    = def
+--         , userLanguages               = Nothing -- TODO: decode and parse preferredLanguages
+--         , userCsvOptions              = def
+--         , userTokensIssuedAfter       = Nothing
+--         , userCreated                 = now
+--         , userDisplayName             = userDisplayName
+--         , userDisplayEmail            = userEmail
+--         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+--         , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+--         , userPostLastUpdate          = Nothing
+--         , userPinPassword             = Nothing -- must be derived via AVS
+--         , userPrefersPostal           = userDefaultPrefersPostal
+--         , ..
+--         }
+--       userUpdate =  
+--         --- [ UserLastAuthentication      =. Just now  | isLogin ] ++
+--         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
+--         [
+--         -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+--           UserFirstName               =. userFirstName
+--         , UserSurname                 =. userSurname
+--         , UserMobile                  =. userMobile
+--         , UserTelephone               =. userTelephone
+--         , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+--         , UserCompanyDepartment       =. userCompanyDepartment
+--         ]
+--     return (newUser, userUpdate)
+-- 
+--   where
+--     azureMap :: Map.Map Text [ByteString]
+--     azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null))
+-- 
+--     -- just returns Nothing on error, pure
+--     decodeAzure :: Text -> Maybe Text
+--     decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr
+-- 
+--     decodeAzure' :: Text -> Text
+--     decodeAzure' = fromMaybe "" . decodeAzure
+-- 
+--     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
+--     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
+--     decodeAzure1 attr err
+--         | (h:_) <- rights vs  = return h
+--         | otherwise           = throwM err
+--       where
+--         vs = Text.decodeUtf8' <$> (azureMap !!! attr)
 
 
-associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
-associateUserSchoolsByTerms uid = do
+associateUserSchoolsByTerms :: MonadIO m => UserAuthId -> SqlPersistT m ()
+associateUserSchoolsByTerms uaid = do
+  uid <- join $ fmap (fromMaybe $ error "associateUserSchoolsByTerms: No User for given UserAuthId!") . getKeyBy . UniqueUser . userAuthIdent <$> getJust uaid
   sfs <- selectList [StudyFeaturesUser ==. uid] []
 
   forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
@@ -616,11 +692,13 @@ associateUserSchoolsByTerms uid = do
         }
 
 
-updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
+updateUserLanguage :: ( MonadHandler m
+                      , HandlerSite m ~ UniWorX
                       , YesodAuth UniWorX
                       , UserId ~ AuthId UniWorX
                       )
-                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
+                   => Maybe Lang
+                   -> SqlPersistT m (Maybe Lang)
 updateUserLanguage (Just lang) = do
   unless (lang `elem` appLanguages) $
     invalidArgs ["Unsupported language"]

From 5c4042e5f30331447b9738ba2911cf0d5b6fd286 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 18 Feb 2024 18:41:29 +0100
Subject: [PATCH 083/178] chore(oauth2): fix query function exports

---
 src/Auth/OAuth2.hs | 17 +++++++++++++----
 1 file changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 75373b083..299b6b2e3 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -11,6 +11,8 @@ module Auth.OAuth2
   , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous
   , apAzureMock
   , azureMockServer
+  , queryOAuth2User
+  , refreshOAuth2Token
   ) where
 
 import qualified Data.CaseInsensitive as CI
@@ -103,7 +105,7 @@ azureMockServer port =
             }
       mockServerURL = "http://localhost:" <> fromString port
       profileSrc = fromString $ mockServerURL <> "/users/me"
-  in  authOAuth2 mockPluginName oa $ \manager token -> do
+  in  authOAuth2 apAzureMock oa $ \manager token -> do
         (UserID userID, userResponse) <- authGetProfile apAzureMock manager token profileSrc
         return Creds
                 { credsPlugin = apAzureMock
@@ -122,8 +124,12 @@ data UserDataException = UserDataJSONException JSONException
 
 instance Exception UserDataException
 
-queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m)
-                => Text
+queryOAuth2User :: forall j m.
+                   ( FromJSON j
+                   , MonadHandler m
+                   , MonadThrow m
+                   )
+                => Text -- ^ User identifier (arbitrary needle)
                 -> m (Either UserDataException j)
 queryOAuth2User userID = runExceptT $ do
   (queryUrl, tokenUrl) <- liftIO mkBaseUrls
@@ -159,7 +165,10 @@ mkBaseUrls = do
 # endif
 
 
-refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m)
+refreshOAuth2Token :: forall m.
+                      ( MonadHandler m
+                      , MonadThrow m
+                      )
                    => (Maybe AccessToken, Maybe RefreshToken)
                    -> String
                    -> Bool

From 96038a4f224e368505a71fec3ceffb3bb7f8f9cb Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 18 Feb 2024 18:42:22 +0100
Subject: [PATCH 084/178] chore(auth): fix azure exception handler

---
 src/Foundation/Yesod/Auth.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index d81d09172..95dd60e80 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -109,7 +109,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           err -> do
             $logErrorS "OAuth" $ tshow err
             mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from?
+            excRecovery . ServerError $ mr MsgInternalLoginError
       , C.Handler $ \(cExc :: UserConversionException) -> do
           $logErrorS "Auth" $ tshow cExc
           mr <- getMessageRender

From bcfcbd5c9b336f0bb93331263adcda187616529d Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 18 Feb 2024 18:43:44 +0100
Subject: [PATCH 085/178] chore(auth): fix redundant imports

---
 src/Foundation/Yesod/Auth.hs | 13 +------------
 1 file changed, 1 insertion(+), 12 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 95dd60e80..975b2b825 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -40,19 +40,8 @@ import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
-import Foundation.Authorization (AuthorizationCacheKey(..))
-import Foundation.I18n
-import Foundation.Type
-import Foundation.Types
-
-import Handler.Utils.LdapSystemFunctions
-import Handler.Utils.Memcached
-import Handler.Utils.Profile
-
 import qualified Ldap.Client as Ldap
 
-import Yesod.Auth.Message
-
 
 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
@@ -64,7 +53,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
   $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
   setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds)
   sess <- getSession
-  $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m"
+  $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
 
   now <- liftIO getCurrentTime
   userAuthConf <- getsYesod $ view _appUserAuthConf

From 9a5c487b2cdd1d79fbb381059d778eab7e60bca1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 19 Feb 2024 01:44:58 +0100
Subject: [PATCH 086/178] chore(auth): switch back to AuthId UniWorX == UserId

---
 models/auth.model            | 18 ++++--------------
 models/users.model           |  3 ++-
 src/Auth/PWHash.hs           |  2 +-
 src/Foundation/Instances.hs  |  3 +--
 src/Foundation/Yesod/Auth.hs | 10 +++++-----
 5 files changed, 13 insertions(+), 23 deletions(-)

diff --git a/models/auth.model b/models/auth.model
index 147fefa9b..4f0420ecf 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -31,28 +31,18 @@ AuthSourceLdap
   deriving Show Eq Ord Generic
 
 
--- | User authentication data, source-agnostic data
-UserAuth
-    ident     UserIdent                    -- Human-readable text uniquely identifying a user
-    lastLogin UTCTime Maybe                -- When did the corresponding User last authenticate using this entry?
-    lastSync  UTCTime Maybe                -- When was the corresponding User entry last synced with any external source?
-    Primary ident
-    UniqueAuthentication ident
-    deriving Show Eq Ord Generic
-
 -- | User authentication data fetched from external user sources
 ExternalAuth
-    ident     UserIdent
+    user      UserId
     source    AuthenticationSourceIdent    -- Identifier of the external source in the config
     data      Value "default='{}'::jsonb"  -- Raw user data from external source
     lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source? -- TODO rethink
-    UniqueExternalAuth ident source        -- At most one entry of this user per source
+    UniqueExternalAuth user source        -- At most one entry of this user per source
     deriving Show Eq Ord Generic
 
 -- | FraDrive-specific user authentication data, internal logins have precedence over external authentication
 InternalAuth
-    ident     UserIdent
+    user      UserId
     hash      Text                         -- Hashed password
-    Primary ident
-    UniqueInternalAuth ident
+    UniqueInternalAuth user
     deriving Show Eq Ord Generic
diff --git a/models/users.model b/models/users.model
index 739b73688..901d30bd9 100644
--- a/models/users.model
+++ b/models/users.model
@@ -47,7 +47,8 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
-    UniqueUser  ident                           -- Column 'ident' can be used as a row-key in this table
+    lastLogin             UTCTime Maybe         -- When did the user last authenticate?
+    UniqueAuthentication  ident                 -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs
index 8dfef326b..fdb85bc8a 100644
--- a/src/Auth/PWHash.hs
+++ b/src/Auth/PWHash.hs
@@ -73,7 +73,7 @@ hashLogin pwHashAlgo = AuthPlugin{..}
           Just (Entity _ InternalAuth{..})
             | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 internalAuthHash) -> do -- (2^) is magic.
                 observeLoginOutcome apName LoginSuccessful
-                setCredsRedirect $ Creds apName (CI.original internalAuthIdent) []
+                setCredsRedirect $ Creds apName (CI.original internalAuthUser) []
           other -> do
             $logDebugS apName $ tshow other
             observeLoginOutcome apName LoginInvalidCredentials
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index 9a8c15327..a217bf91c 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -121,7 +121,7 @@ instance YesodPersistRunner UniWorX where
 
 
 instance YesodAuth UniWorX where
-    type AuthId UniWorX = UserAuthId
+    type AuthId UniWorX = UserId
 
     -- Where to send a user after successful login
     loginDest _ = NewsR
@@ -172,7 +172,6 @@ instance YesodAuth UniWorX where
               BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
               hoistMaybe bearerImpersonate
 
--- TODO: update to new AuthId!
 instance YesodAuthPersist UniWorX where
   getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
   getAuthEntity = liftHandler . runDBRead . get
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 975b2b825..d805aba9f 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -45,7 +45,7 @@ import qualified Ldap.Client as Ldap
 
 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
-                , YesodAuth UniWorX, UserAuthId ~ AuthId UniWorX
+                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                 )
              => Creds UniWorX
              -> m (AuthenticationResult UniWorX)
@@ -77,6 +77,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       = return res
 
     excHandlers =
+      -- TODO: merge ldap and azure exception types
       [ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of
           LdapUserNoResult -> do
             $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
@@ -116,7 +117,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           -> return ()
       case res of
         Authenticated uid
-          | not isDummy -> res <$ update uid [ UserAuthLastLogin =. Just now ]
+          | not isDummy -> res <$ update uid [ UserLastLogin =. Just now ]
         _other -> return res
 
   $logDebugS "Auth" $ tshow Creds{..}
@@ -691,9 +692,8 @@ decodeUser now UserDefaultConf{..} upsertData = do
 --         vs = Text.decodeUtf8' <$> (azureMap !!! attr)
 
 
-associateUserSchoolsByTerms :: MonadIO m => UserAuthId -> SqlPersistT m ()
-associateUserSchoolsByTerms uaid = do
-  uid <- join $ fmap (fromMaybe $ error "associateUserSchoolsByTerms: No User for given UserAuthId!") . getKeyBy . UniqueUser . userAuthIdent <$> getJust uaid
+associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
+associateUserSchoolsByTerms uid = do
   sfs <- selectList [StudyFeaturesUser ==. uid] []
 
   forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do

From 956464659eccdb519ad9a18ca05b908486904b27 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Mon, 19 Feb 2024 00:52:15 +0000
Subject: [PATCH 087/178] feat(auth): link to sso test from dev login widget

---
 shell.nix                   | 3 ++-
 src/Foundation/Instances.hs | 8 ++++++++
 templates/login.hamlet      | 7 ++++++-
 3 files changed, 16 insertions(+), 2 deletions(-)

diff --git a/shell.nix b/shell.nix
index 8c3f8b97e..7b3fd32e9 100644
--- a/shell.nix
+++ b/shell.nix
@@ -9,7 +9,8 @@ let
 
   haskellPackages = pkgs.haskellPackages;
 
-  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=d47908b4f7883b4b485abf1ee06645495ccdc7b3&ref=user-queries").packages.x86_64-linux;
+  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=45debf40cd171f78a4de38f608a6cfd3be73b91a&ref=oidc").packages.x86_64-linux;
+
 
   oauth2MockServer = oauth2Flake.default;
   mkOauth2DB = oauth2Flake.mkOauth2DB;
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index 20d10b2de..49b6b5de9 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -42,6 +42,8 @@ import Foundation.DB
 
 import Network.Wai.Parse (lbsBackEnd)
 
+import System.Environment (lookupEnv)
+
 import UnliftIO.Pool (withResource)
 
 import qualified Control.Monad.State.Class as State
@@ -136,6 +138,12 @@ instance YesodAuth UniWorX where
         plugins <- getsYesod authPlugins
         $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
 
+#ifdef DEVELOPMENT
+        mPort <- liftIO $ lookupEnv "OAUTH2_SERVER_PORT"
+#else
+        let mPort = Nothing
+#endif
+
         setTitleI MsgLoginTitle
         $(widgetFile "login")
 
diff --git a/templates/login.hamlet b/templates/login.hamlet
index bb3ee704e..e5dc2706f 100644
--- a/templates/login.hamlet
+++ b/templates/login.hamlet
@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,David Mosbach 
+$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , David Mosbach 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -26,3 +26,8 @@ $forall AuthPlugin{apName, apLogin} <- plugins
     

       
_{MsgDummyLoginTitle}
       ^{apLogin toParent}
+$maybe port <- mPort
+  

+    
SSO Dev Test
+    Test login via single sign-on
+  

From a1d8dc2e7eb31952ececd504b42d1b6700efb5c0 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 19 Feb 2024 02:24:31 +0100
Subject: [PATCH 088/178] chore(auth): migrate password hash back to User model

---
 models/auth.model               |  7 -------
 models/users.model              |  3 ++-
 src/Auth/PWHash.hs              | 11 ++++++-----
 src/Foundation/Authorization.hs |  9 ++++-----
 src/Foundation/Navigation.hs    |  4 ++--
 src/Foundation/Yesod/Auth.hs    | 22 ++++++++--------------
 6 files changed, 22 insertions(+), 34 deletions(-)

diff --git a/models/auth.model b/models/auth.model
index 4f0420ecf..121d9440d 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -39,10 +39,3 @@ ExternalAuth
     lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source? -- TODO rethink
     UniqueExternalAuth user source        -- At most one entry of this user per source
     deriving Show Eq Ord Generic
-
--- | FraDrive-specific user authentication data, internal logins have precedence over external authentication
-InternalAuth
-    user      UserId
-    hash      Text                         -- Hashed password
-    UniqueInternalAuth user
-    deriving Show Eq Ord Generic
diff --git a/models/users.model b/models/users.model
index 901d30bd9..7a2849968 100644
--- a/models/users.model
+++ b/models/users.model
@@ -14,6 +14,8 @@
 
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
     ident          UserIdent                -- Case-insensitive user-identifier
+    passwordHash   Text Maybe        -- If specified, allows the user to login with credentials independently of external authentication
+    lastLogin      UTCTime Maybe     -- When did the user last authenticate?
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
@@ -47,7 +49,6 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
-    lastLogin             UTCTime Maybe         -- When did the user last authenticate?
     UniqueAuthentication  ident                 -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs
index fdb85bc8a..bd8664668 100644
--- a/src/Auth/PWHash.hs
+++ b/src/Auth/PWHash.hs
@@ -68,12 +68,13 @@ hashLogin pwHashAlgo = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
-        auth :: Maybe (Entity InternalAuth) <- liftHandler . runDB . getBy $ UniqueInternalAuth hashIdent
-        case auth of
-          Just (Entity _ InternalAuth{..})
-            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 internalAuthHash) -> do -- (2^) is magic.
+        user :: Maybe (Entity User) <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
+        case user of
+          Just (Entity _ User{userIdent,userPasswordHash})
+            | Just pwHash <- userPasswordHash
+            , verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 pwHash) -> do -- (2^) is magic.
                 observeLoginOutcome apName LoginSuccessful
-                setCredsRedirect $ Creds apName (CI.original internalAuthUser) []
+                setCredsRedirect $ Creds apName (CI.original userIdent) []
           other -> do
             $logDebugS apName $ tshow other
             observeLoginOutcome apName LoginInvalidCredentials
diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index 4f36e5e31..b85e397d7 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -1531,11 +1531,10 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu
     CourseR _ _ _ (CUserR cID) -> return cID
     _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
+  let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
   maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
-    User{..} <- MaybeT $ get referencedUser'
-    let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
-    guardM . lift $ exists [ ExternalAuthIdent ==. userIdent, ExternalAuthSource <-. availableSources ]
-    guardM . lift . fmap not . existsBy $ UniqueInternalAuth userIdent
+    Entity uid _ <- MaybeT $ getEntity referencedUser'
+    guardM . lift $ exists [ ExternalAuthUser ==. uid, ExternalAuthSource <-. availableSources ]
   return Authorized
 tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
@@ -1549,7 +1548,7 @@ tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return retu
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
   maybeTMExceptT (unauthorizedI MsgUnauthorizedInternal) $ do
     User{..} <- MaybeT $ get referencedUser'
-    guardM . lift . existsBy $ UniqueInternalAuth userIdent
+    guard $ is _Just userPasswordHash
   return Authorized
 tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index 6cdfe8b25..75cb1fdf7 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -1221,8 +1221,8 @@ pageActions (AdminUserR cID) = return
       , navRoute       = UserPasswordR cID
       , navAccess' = NavAccessDB $ do
           uid <- decrypt cID
-          User{userIdent} <- get404 uid
-          existsBy $ UniqueInternalAuth userIdent
+          User{userPasswordHash} <- get404 uid
+          return $ is _Just userPasswordHash
       , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index d805aba9f..ee2b9fd7f 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -183,7 +183,7 @@ ldapLookupAndUpsert :: forall m.
                        , MonadUnliftIO m
                        )
                     => Text
-                    -> SqlPersistT m (Entity UserAuth)
+                    -> SqlPersistT m (Entity User)
 ldapLookupAndUpsert ident = 
   getsYesod (view _appLdapPool) >>= \case 
     Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
@@ -201,8 +201,8 @@ upsertUser :: forall m.
                   )
                => UpsertUserMode
                -> UpsertUserData
-               -> SqlPersistT m (Entity UserAuth)
-upsertUser upsertMode upsertData = do
+               -> SqlPersistT m (Entity User)
+upsertUser _upsertMode upsertData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
@@ -211,9 +211,9 @@ upsertUser upsertMode upsertData = do
 
   oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
 
-  _user@(Entity userId userRec) <- case oldUsers of
+  user@(Entity userId userRec) <- case oldUsers of
     [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other      -> upsertBy (UniqueUser (newUser ^. _userIdent)) newUser userUpdate
+    _other      -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
 
   -- sets display name
   -- TODO: use display name from external source, if possible
@@ -252,15 +252,7 @@ upsertUser upsertMode upsertData = do
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  let (userAuthLastLogin, userAuthLastSync) = case upsertMode of
-        UpsertUserSync{}      -> (Nothing , Just now)
-        UpsertUserGuessUser{} -> (Nothing , Nothing )
-        _other                -> (Just now, Nothing )
-  userAuth <- upsertBy (UniqueAuthentication $ newUser ^. _userIdent) UserAuth{ userAuthIdent = newUser ^. _userIdent, ..} $
-    [ UserAuthLastLogin =. Just lastLogin | lastLogin <- maybeToList userAuthLastLogin ] ++
-    [ UserAuthLastSync  =. Just lastSync  | lastSync  <- maybeToList userAuthLastSync  ]
-
-  return userAuth
+  return user
 
 -- | Upsert User DB according to given Azure data (does not query Azure itself)
 -- upsertAzureUser :: forall m.
@@ -396,6 +388,8 @@ decodeUser now UserDefaultConf{..} upsertData = do
         , userPostLastUpdate        =  Nothing
         , userPinPassword           =  Nothing -- must be derived via AVS
         , userPrefersPostal         =  userDefaultPrefersPostal
+        , userPasswordHash          =  Nothing
+        , userLastLogin             =  Nothing
         , ..
         }
       userUpdate =

From ed54b666ec7d072c1e3c1390c19884afd4c756f4 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 19 Feb 2024 23:46:45 +0100
Subject: [PATCH 089/178] chore: add todos

---
 models/auth.model | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/models/auth.model b/models/auth.model
index 121d9440d..bd5adc6f6 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -2,6 +2,7 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+-- TODO: AuthSourceAzure and AuthSourceLdap to be removed, just use config settings!
 
 -- | AzureADv2 (Microsoft Graph) user authentication sources, parsed from application settings
 -- | Note: No host specification is needed since Azure authentication is always requested at https://graph.microsoft.com/ (Microsoft Graph API)
@@ -31,6 +32,7 @@ AuthSourceLdap
   deriving Show Eq Ord Generic
 
 
+-- TODO: define AuthenticationSource with json instances to store unique source identifiers per protocol
 -- | User authentication data fetched from external user sources
 ExternalAuth
     user      UserId

From 3d1908d71a177dee6fdf3a80d0b1d8385caaafe2 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 19 Feb 2024 23:48:33 +0100
Subject: [PATCH 090/178] chore(users): tweak addNewUser to conform to new
 model

---
 src/Handler/Utils/Avs.hs |  3 +--
 src/Utils/Users.hs       | 30 ++++--------------------------
 2 files changed, 5 insertions(+), 28 deletions(-)

diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 0f0b8094b..fbc80bd3e 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -460,8 +460,7 @@ upsertAvsUserById api = do
             , audPinPassword      = userPin
             , audEmail = fakeNo    -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
             , audIdent = fakeIdent -- use AvsPersonId instead
-            , audAuth  = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
-            , audAzureId = Nothing -- TODO
+          --, audAuth  = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
             }
       mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
       whenIsJust mbUid $ \uid -> runDB $ do        
diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs
index 7c35da5fb..24c588fb1 100644
--- a/src/Utils/Users.hs
+++ b/src/Utils/Users.hs
@@ -5,31 +5,15 @@
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 
 module Utils.Users
-  ( AuthenticationKind(..)
-  , AddUserData(..)
+  ( AddUserData(..)
   , addNewUser
   ) where
 
 import Import
 
 
-data AuthenticationKind = AuthKindLDAP | AuthKindAzure | AuthKindPWHash | AuthKindNoLogin
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Universe, Finite)
-embedRenderMessage ''UniWorX ''AuthenticationKind id
-nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
+-- TODO: addNewUser might be redundant; use upsertUser instead?
 
-mkAuthMode :: AuthenticationKind -> AuthenticationMode
-mkAuthMode AuthKindLDAP     = AuthLDAP
-mkAuthMode AuthKindAzure    = AuthAzure
-mkAuthMode AuthKindPWHash   = AuthPWHash ""
-mkAuthMode AuthKindNoLogin  = AuthNoLogin
-
-{-
-classifyAuth :: AuthenticationMode -> AuthenticationKind
-classifyAuth AuthLDAP     = AuthKindLDAP
-classifyAuth AuthPWHash{} = AuthKindPWHash
-classifyAuth AuthNoLogin  = AuthKindNoLogin
--} 
 
 data AddUserData = AddUserData
   { audTitle            :: Maybe Text
@@ -49,8 +33,6 @@ data AddUserData = AddUserData
   , audPinPassword      :: Maybe Text
   , audEmail            :: UserEmail
   , audIdent            :: UserIdent
-  , audAuth             :: AuthenticationKind
-  , audAzureId          :: Maybe UUID
   }
 
 
@@ -62,6 +44,8 @@ addNewUser AddUserData{..} = do
   let 
     newUser = User
       { userIdent                   = audIdent
+      , userLastLogin               = Nothing
+      , userPasswordHash            = Nothing
       , userMaxFavourites           = userDefaultMaxFavourites
       , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
       , userTheme                   = userDefaultTheme
@@ -78,11 +62,6 @@ addNewUser AddUserData{..} = do
       , userCsvOptions              = def { csvFormat = review csvPreset CsvPresetXlsx }
       , userTokensIssuedAfter       = Nothing
       , userCreated                 = now
-      , userLastLdapSynchronisation = Nothing
-      , userLdapPrimaryKey          = audFPersonalNumber
-      , userLastAzureSynchronisation = Nothing
-      , userAzurePrimaryKey         = audAzureId
-      , userLastAuthentication      = Nothing
       , userEmail                   = audEmail
       , userDisplayName             = audDisplayName
       , userDisplayEmail            = audDisplayEmail
@@ -100,6 +79,5 @@ addNewUser AddUserData{..} = do
       , userPrefersPostal           = audPrefersPostal
       , userPinPassword             = audPinPassword
       , userMatrikelnummer          = audMatriculation
-      , userAuthentication          = mkAuthMode audAuth
       }
   runDB $ insertUnique newUser
\ No newline at end of file

From b8e7ee2b3d1c35a82acb5567e505d075632ea018 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 19 Feb 2024 23:49:17 +0100
Subject: [PATCH 091/178] chore(users): remove old auth kind digesting

---
 src/Handler/Utils/Users.hs | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 45b738c07..2733a25b2 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -6,9 +6,9 @@
 
 -- NOTE: Also see Handler.Utils.Profile for similar utilities
 module Handler.Utils.Users
-  ( computeUserAuthenticationDigest
-  , Digest, SHA3_256
-  , constEq
+  ( -- computeUserAuthenticationDigest
+    -- , Digest, SHA3_256
+    constEq
   , NameMatchQuality(..)
   , matchesName
   , GuessUserInfo(..)
@@ -25,7 +25,7 @@ module Handler.Utils.Users
 
 import Import
 import Auth.LDAP (ldapUserMatr')
-import Foundation.Yesod.Auth (upsertLdapUser)
+import Foundation.Yesod.Auth (upsertUser)
 
 import Crypto.Hash (hashlazy)
 
@@ -131,8 +131,8 @@ getSupervisees = do
   return $ Set.insert uid $ Set.fromAscList svs 
 
 
-computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
-computeUserAuthenticationDigest = hashlazy . JSON.encode
+-- computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
+-- computeUserAuthenticationDigest = hashlazy . JSON.encode
 
 
 data GuessUserInfo

From 115452035d4c54811d382a23c4391f51983fe1f2 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 20 Feb 2024 00:05:56 +0100
Subject: [PATCH 092/178] refactor(jobs): SynchroniseUserdb -> SynchroniseUsers

---
 src/Jobs/Crontab.hs                   |  2 +-
 src/Jobs/Handler/SynchroniseUser.hs   | 69 +++++++++++++++++++++++++
 src/Jobs/Handler/SynchroniseUserdb.hs | 72 ---------------------------
 src/Jobs/Types.hs                     | 10 ++--
 4 files changed, 75 insertions(+), 78 deletions(-)
 create mode 100644 src/Jobs/Handler/SynchroniseUser.hs
 delete mode 100644 src/Jobs/Handler/SynchroniseUserdb.hs

diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index c65dd414f..476cfe841 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -317,7 +317,7 @@ determineCrontab = execWriterT $ do
 
           forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
             tell $ HashMap.singleton
-              (JobCtlQueue JobSynchroniseUserdb
+              (JobCtlQueue JobSynchroniseUsers
                  { jEpoch         = fromInteger nextEpoch
                  , jNumIterations = fromInteger numIntervals
                  , jIteration     = fromInteger nextInterval
diff --git a/src/Jobs/Handler/SynchroniseUser.hs b/src/Jobs/Handler/SynchroniseUser.hs
new file mode 100644
index 000000000..883dc8ca6
--- /dev/null
+++ b/src/Jobs/Handler/SynchroniseUser.hs
@@ -0,0 +1,69 @@
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen 
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Jobs.Handler.SynchroniseUser
+  ( dispatchJobSynchroniseUsers, dispatchJobSynchroniseUser
+  , SynchroniseUserException(..)
+  ) where
+
+import Import
+
+import qualified Data.Conduit.List as C
+
+import Auth.LDAP
+import Auth.OAuth2
+import Foundation.Yesod.Auth (UserConversionException, upsertUser)
+
+import Jobs.Queue
+
+
+data SynchroniseUserException
+  = SynchroniseUserNoSource
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+instance Exception SynchroniseUserException
+
+dispatchJobSynchroniseUsers :: Natural -> Natural -> Natural -> JobHandler UniWorX
+dispatchJobSynchroniseUsers numIterations epoch iteration
+  = JobHandlerAtomic . runConduit $
+      readUsers .| filterIteration .| sinkDBJobs
+  where
+    readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
+    readUsers = selectKeys [] []
+
+    filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
+    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
+      let
+        userIteration, currentIteration :: Integer
+        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
+        currentIteration = toInteger iteration `mod` toInteger numIterations
+      $logDebugS "SynchroniseUsers" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
+      guard $ userIteration == currentIteration
+
+      return $ JobSynchroniseUser userId
+
+dispatchJobSynchroniseUser :: UserId -> JobHandler UniWorX
+dispatchJobSynchroniseUser jUser = JobHandlerException $ do
+  userSourceConf <- getsYesod $ view _appUserAuthConf
+  case userSourceConf of
+    UserAuthConfSingleSource (AuthSourceConfLdap _ldapConf) ->
+      runDB . void . runMaybeT . handleExc $ do
+        ldapPool@(upsertUserLdapConf,_) <- MaybeT . getsYesod $ view _appLdapPool
+        user@User{userIdent = upsertUserIdent} <- MaybeT $ get jUser
+        $logInfoS "SynchroniseUser" [st|Synchronising #{upsertUserIdent} with LDAP|]
+        -- reTestAfter <- getsYesod $ view _appUserdbRetestFailover
+        -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user
+        upsertUserLdapData <- MaybeT $ ldapUser' ldapPool user
+        void . lift $ upsertUser UpsertUserSync{..} UpsertUserDataLdap{..}
+    UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) ->
+      runDB . void . runMaybeT . handleExc $ do
+        user@User{userIdent = upsertUserIdent} <- MaybeT $ get jUser
+        $logInfoS "SynchroniseUser" [st|Synchronising #{upsertUserIdent} with Azure|]
+        upsertUserAzureData <- MaybeT $ azureUser' upsertUserAzureConf user
+        void . lift $ upsertUser UpsertUserSync{..} UpsertUserDataAzure{..}
+  where
+    handleExc :: MaybeT DB a -> MaybeT DB a
+    handleExc
+      = catchMPlus (Proxy @AzureUserException)
+      . catchMPlus (Proxy @LdapUserException)
+      . catchMPlus (Proxy @UserConversionException)
diff --git a/src/Jobs/Handler/SynchroniseUserdb.hs b/src/Jobs/Handler/SynchroniseUserdb.hs
deleted file mode 100644
index dab3233a0..000000000
--- a/src/Jobs/Handler/SynchroniseUserdb.hs
+++ /dev/null
@@ -1,72 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen 
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Jobs.Handler.SynchroniseUserdb
-  ( dispatchJobSynchroniseUserdb, dispatchJobSynchroniseUserdbUser
-  , SynchroniseUserdbException(..)
-  ) where
-
-import Import
-
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Conduit.List as C
-import qualified Data.UUID as UUID
-
-import Auth.LDAP
-import Auth.OAuth2
-import Foundation.Yesod.Auth (CampusUserConversionException, upsertLdapUser, upsertAzureUser)
-
-import Jobs.Queue
-
-
-data SynchroniseUserdbException
-  = SynchroniseUserdbNoUserdb
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Exception SynchroniseUserdbException
-
-dispatchJobSynchroniseUserdb :: Natural -> Natural -> Natural -> JobHandler UniWorX
-dispatchJobSynchroniseUserdb numIterations epoch iteration
-  = JobHandlerAtomic . runConduit $
-      readUsers .| filterIteration .| sinkDBJobs
-  where
-    readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
-    readUsers = selectKeys [] []
-
-    filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
-    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
-      let
-        userIteration, currentIteration :: Integer
-        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
-        currentIteration = toInteger iteration `mod` toInteger numIterations
-      $logDebugS "SynchroniseUserdb" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
-      guard $ userIteration == currentIteration
-
-      return $ JobSynchroniseUserdbUser userId
-
-dispatchJobSynchroniseUserdbUser :: UserId -> JobHandler UniWorX
-dispatchJobSynchroniseUserdbUser jUser = JobHandlerException $ do
-  userSourceConf <- getsYesod $ view _appUserSourceConf
-  case userSourceConf of
-    UserSourceConfSingleSource (UserSourceLdap _ldapConf) ->
-      runDB . void . runMaybeT . handleExc $ do
-        ldapPool <- MaybeT . getsYesod $ view _appLdapPool
-        user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
-        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey
-        $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with LDAP|]
-        -- reTestAfter <- getsYesod $ view _appUserdbRetestFailover
-        -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user
-        ldapAttrs <- MaybeT $ ldapUser' ldapPool user
-        void . lift $ upsertLdapUser (UpsertUserSync upsertIdent) ldapAttrs
-    UserSourceConfSingleSource (UserSourceAzureAdV2 azureConf) ->
-      runDB . void . runMaybeT . handleExc $ do
-        user@User{userIdent,userAzurePrimaryKey} <- MaybeT $ get jUser
-        let upsertIdent = maybe userIdent (CI.mk . UUID.toText) userAzurePrimaryKey -- TODO: use userPrincipalName
-        $logInfoS "SynchroniseUserdb" [st|Synchronising #{upsertIdent} with Azure|]
-        azureAttrs <- MaybeT $ azureUser' azureConf user
-        void . lift $ upsertAzureUser (UpsertUserSync upsertIdent) azureAttrs
-  where
-    handleExc :: MaybeT DB a -> MaybeT DB a
-    handleExc
-      = catchMPlus (Proxy @CampusUserException)
-      . catchMPlus (Proxy @CampusUserConversionException)
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 2e8100cd1..107bf627c 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -92,11 +92,11 @@ data Job
   | JobTruncateTransactionLog
   | JobPruneInvitations
   | JobDeleteTransactionLogIPs
-  | JobSynchroniseUserdb      { jNumIterations
+  | JobSynchroniseUsers       { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
                               }
-  | JobSynchroniseUserdbUser  { jUser :: UserId }
+  | JobSynchroniseUser        { jUser :: UserId }
   | JobSynchroniseAvs         { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
@@ -348,8 +348,8 @@ jobNoQueueSame = \case
   JobTruncateTransactionLog{}         -> Just JobNoQueueSame
   JobPruneInvitations{}               -> Just JobNoQueueSame
   JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
-  JobSynchroniseUserdb{}              -> Just JobNoQueueSame
-  JobSynchroniseUserdbUser{}          -> Just JobNoQueueSame
+  JobSynchroniseUsers{}               -> Just JobNoQueueSame
+  JobSynchroniseUser{}                -> Just JobNoQueueSame
   JobSynchroniseAvs{}                 -> Just JobNoQueueSame
   JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
   JobSynchroniseAvsId{}               -> Just JobNoQueueSame

From 0a01490aa77512dc7fed936f899c1e77b60c301f Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 20 Feb 2024 00:09:31 +0100
Subject: [PATCH 093/178] chore(auth): use ldap external auth in health reports

---
 src/Jobs/HealthReport.hs | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index ea9ef1c19..403a78f4c 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -113,18 +113,21 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
 --reTestAfter <- getsYesod $ view _appUserdbRetestFailover
   case ldapPool' of
     Just ldapPool -> do
+      currentLdapSources <- return [] -- TODO: fetch from current user-auth config
       ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
         E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
         E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
-        E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
+        E.where_ . E.exists . E.from $ \externalAuth -> E.where_ $
+                externalAuth E.^. ExternalAuthUser E.==. user E.^. UserId
+          E.&&. externalAuth E.^. ExternalAuthSource `E.in_` E.valList currentLdapSources
         return $ user E.^. UserIdent
       for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
         let numAdmins = genericLength ldapAdminUsers
         Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
-          let hCampusExc :: CampusUserException -> Handler (Sum Integer)
-              hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
-           in handle hCampusExc $ Sum 1 <$ ldapUser ldapPool (Creds apLdap adminIdent [])
-         --in handle hCampusExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent [])
+          let hLdapExc :: LdapUserException -> Handler (Sum Integer)
+              hLdapExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
+           in handle hLdapExc $ Sum 1 <$ ldapUser ldapPool (Creds apLdap adminIdent [])
+         --in handle hLdapExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent [])
         if
           | numAdmins >= 1 -> return $ numResolved % numAdmins
           | otherwise      -> return 0

From 9bf7033eaccdbe09f083e512da2d23a87a8507e2 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 20 Feb 2024 00:13:55 +0100
Subject: [PATCH 094/178] chore(guess-user): remove eppn lookup

---
 src/Handler/Utils/Users.hs | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 2733a25b2..f91f9136b 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -138,8 +138,6 @@ getSupervisees = do
 data GuessUserInfo
   = GuessUserMatrikelnummer
     { guessUserMatrikelnummer         :: UserMatriculation          }
-  | GuessUserEduPersonPrincipalName
-    { guessUserEduPersonPrincipalName :: UserEduPersonPrincipalName }
   | GuessUserDisplayName
     { guessUserDisplayName            :: UserDisplayName            }
   | GuessUserSurname
@@ -191,7 +189,6 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
 
     toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
       GuessUserMatrikelnummer         userMatriculation' -> user E.^. UserMatrikelnummer  E.==.          E.val (Just userMatriculation')
-      GuessUserEduPersonPrincipalName userEPPN'          -> user E.^. UserLdapPrimaryKey  E.==.          E.val (Just userEPPN')
       GuessUserDisplayName            userDisplayName'   -> user E.^. UserDisplayName    `containsAsSet` userDisplayName'
       GuessUserSurname                userSurname'       -> user E.^. UserSurname        `containsAsSet` userSurname'
       GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'

From 8a353c357fa81972e33cf63439daeb58352f4e72 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 20 Feb 2024 00:38:46 +0100
Subject: [PATCH 095/178] chore(users): tweak assimilateUsers for new config

---
 src/Handler/Utils/Users.hs | 15 +++++++--------
 1 file changed, 7 insertions(+), 8 deletions(-)

diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index f91f9136b..e906e59d2 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -27,17 +27,16 @@ import Import
 import Auth.LDAP (ldapUserMatr')
 import Foundation.Yesod.Auth (upsertUser)
 
-import Crypto.Hash (hashlazy)
+-- import Crypto.Hash (hashlazy)
 
 import Data.ByteArray (constEq)
 import Data.Maybe (fromJust)
 import qualified Data.List.NonEmpty as NonEmpty (fromList)
 
-import qualified Data.Aeson as JSON
+-- import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
 
 import qualified Data.Set as Set
--- import qualified Data.List as List
 import qualified Data.CaseInsensitive as CI
 
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -235,11 +234,12 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | EQ <- x `closeness` x' = x : takeClosest (x':xs)
             | otherwise = [x]
 
+          -- TODO: Generalize
           doLdap userMatr = do
             ldapPool' <- getsYesod $ view _appLdapPool
-            fmap join . for ldapPool' $ \ldapPool -> do
+            fmap join . for ldapPool' $ \ldapPool@(upsertUserLdapConf,_) -> do
               ldapData <- ldapUserMatr' ldapPool userMatr
-              for ldapData $ upsertLdapUser UpsertUserGuessUser
+              for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}
 
       let
         getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
@@ -909,9 +909,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
 
   update newUserId $ catMaybes          -- NOTE: persist does shortcircuit null updates as expected
-      [ mergeMaybe UserLdapPrimaryKey
-      , mergeBy (<) UserAuthentication
-      , mergeBy (>) UserLastAuthentication
+      [ mergeMaybe  UserPasswordHash
+      , mergeBy (>) UserLastLogin
       , mergeBy (<) UserCreated
       , toMaybe (not (validEmail' (newUser ^. _userEmail       )) && validEmail' (oldUser ^. _userEmail))
                 (UserEmail =. oldUser ^. _userEmail)

From a2e01e74af7018fbf8da9b31b4834a9a5c2afc96 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 20 Feb 2024 01:33:34 +0100
Subject: [PATCH 096/178] chore(notifications): reimplement authmode-update
 notification to support new login modes

---
 .../send/send_notifications/de-de-formal.msg  | 11 +++++-----
 .../send/send_notifications/en-eu.msg         |  9 ++++----
 src/Foundation/Yesod/Auth.hs                  |  2 +-
 .../SendNotification/UserAuthModeUpdate.hs    |  2 +-
 templates/mail/userAuthModeUpdate.hamlet      | 22 +++++++++----------
 5 files changed, 21 insertions(+), 25 deletions(-)

diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg
index cba2c8110..2c0907f7c 100644
--- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg
+++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -75,11 +75,10 @@ NotPassed: Nicht bestanden
 
 #userAuthModeUpdate.hs + templates
 MailSubjectUserAuthModeUpdate: Ihr FRADrive-Login
-UserAuthModeChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennung (Büko) in FRADrive einloggen.
-UserAuthModeChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen.
-UserAuthModeChangedToNoLogin: Ihr Login auf der FRADrive Webseite wurde deaktiviert, aber ihr FRADrive Konto besteht weiterhin. Gültigkeit und Verlängerungen Ihrer Qualifikationen sind dadurch nicht beeinträchtigt. Wenden Sie sich an die Fahrschuladmins, wenn der Login auf der FRADrive Webseite benötigt werden sollte.
-AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
-PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
+UserAuthPasswordEnabled: Sie können sich nun mit einer FRADrive-internen Kennung einloggen.
+UserAuthPasswordDisabled: Sie können sich nun nicht mehr mit Ihrer FRADrive-internen Kennung einloggen.
+AuthExternalLoginTip: Sollten Sie Zugriff zu einem von FRADrive unterstützten externen Account (Azure-Login über Fraport-Kennung, Fraport-BüKo-Login) besitzen, so können Sie sich mit Ihren externen Login-Daten in FRADrive einloggen.
+PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie aus Sicherheitsgründen in einer separaten E-Mail.
 MailFradrive !ident-ok: FRADrive
 MailBodyFradrive: ist die Führerscheinverwaltungsapp der Fraport AG.
 
diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg
index 04fe30088..dc9b17327 100644
--- a/messages/uniworx/categories/send/send_notifications/en-eu.msg
+++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -75,10 +75,9 @@ NotPassed: Failed
 
 #userAuthModeUpdate.hs + templates
 MailSubjectUserAuthModeUpdate: Your FRADrive login
-UserAuthModeChangedToLDAP: You can now log in to FRADrive using your Fraport AG account (Büko)
-UserAuthModeChangedToPWHash: You can now log in using your FRADrive-internal account
-UserAuthModeChangedToNoLogin: Your login for the FRADrive website has been deactivated, but you FRADrive account persists. This has no effect on you qualifications. Please contact the driving school admins, if you need new login credentials for the FRADrive website.
-AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in.
+UserAuthPasswordEnabled: You can now log in using your FRADrive-internal account credentials.
+UserAuthPasswordDisabled: You can no longer log in using your FRADrive-internal account credentials.
+AuthExternalLoginTip: If you have access to an external account supported by FRADrive (Azure login via Fraport identification, Fraport-BüKo login), you can login in FRADrive using your external credentials.
 PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email.
 MailFradrive: FRADrive
 MailBodyFradrive: is the apron driver's licence management app of Fraport AG.
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index ee2b9fd7f..17a64afec 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -221,7 +221,7 @@ upsertUser _upsertMode upsertData = do
                            (newUser ^. _userFirstName)
                            (newUser ^. _userSurname)
                            (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
+    update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
 
   -- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure)
   -- when (validEmail' (userRec ^. _userEmail)) $ do
diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs
index b89e45c82..a03beb3fc 100644
--- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs
+++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet
index 95494335e..6fb694a6f 100644
--- a/templates/mail/userAuthModeUpdate.hamlet
+++ b/templates/mail/userAuthModeUpdate.hamlet
@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost 
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -19,21 +19,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       }
   
     

-      $case userAuthentication
-        $of AuthLDAP
-          _{SomeMessage MsgUserAuthModeChangedToLDAP}
-        $of AuthPWHash _
-          _{SomeMessage MsgUserAuthModeChangedToPWHash}
-        $of AuthNoLogin
-          _{SomeMessage MsgUserAuthModeChangedToNoLogin}
+      $if is _Just userPasswordHash
+        _{SomeMessage MsgUserAuthPasswordEnabled}
+      $else
+        _{SomeMessage MsgUserAuthPasswordDisabled}
     

       
         _{SomeMessage MsgMailFradrive} #
       _{SomeMessage MsgMailBodyFradrive}
 
-    $if is _AuthPWHash userAuthentication
-      

-        _{SomeMessage MsgAuthPWHashTip}
+    $if is _Just userPasswordHash
       

         

           _{SomeMessage MsgPWHashIdent}
@@ -42,6 +37,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         
_{SomeMessage MsgPWHashPassword}
         

           _{SomeMessage MsgPasswordResetEmailIncoming}
+    $else
+      

+        _{SomeMessage MsgAuthExternalLoginTip}
 
-    $if is _Just userLastAuthentication
+    $if is _Just userLastLogin
       ^{editNotifications}

From 41b14f1ecece57c4079a2fae0779bc7f4d35a3c6 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 02:02:58 +0100
Subject: [PATCH 097/178] chore(model): replace auth-source model tables with
 AuthSourceIdent jsonified unique ids

---
 models/auth.model       | 32 +--------------------
 src/Model/Types/Auth.hs | 61 ++++++++++++++++++-----------------------
 2 files changed, 28 insertions(+), 65 deletions(-)

diff --git a/models/auth.model b/models/auth.model
index bd5adc6f6..4582ab43d 100644
--- a/models/auth.model
+++ b/models/auth.model
@@ -2,41 +2,11 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
--- TODO: AuthSourceAzure and AuthSourceLdap to be removed, just use config settings!
-
--- | AzureADv2 (Microsoft Graph) user authentication sources, parsed from application settings
--- | Note: No host specification is needed since Azure authentication is always requested at https://graph.microsoft.com/ (Microsoft Graph API)
-AuthSourceAzure
-  clientId       UUID         -- ^ Azure Client ID of this application
-  clientSecret   Text         -- ^ Azure Client Secret of this application
-  tenantId       UUID         -- ^ Azure Tenant ID of the Azure source
-  scopes         AzureScopes  -- ^ Azure Scopes this application (client) is authorized for
-  UniqueAuthSourceAzure clientId -- TODO rethink!
-  Primary clientId -- TODO rethink!
-  deriving Show Eq Ord Generic
-
--- | LDAP user authentication sources, parsed from application settings
-AuthSourceLdap
-  host           Text         -- ^ LDAP host destination to connect to
-                              -- TODO: switch to url type
-  port           Word16       -- ^ Port of the LDAP service to connect to
-                              -- TODO: Maybe merge with host and make primary key?
-  tls            Bool         -- ^ Whether to connect to the host via TLS
-  user           LdapDn       -- ^ User used for queries
-  pass           LdapPass     -- ^ Password used for queries
-  base           LdapDn       -- ^ TODO documentation needed
-  scope          LdapScope    -- ^ TODO documentation needed
-  timeout        NominalDiffTime  -- ^ Query timeout
-  searchTimeout  Int32            -- ^ Search query timeout -- TODO: why not NominalDiffTime??
-  UniqueAuthSourceLdap host port -- TODO rethink!
-  deriving Show Eq Ord Generic
-
-
 -- TODO: define AuthenticationSource with json instances to store unique source identifiers per protocol
 -- | User authentication data fetched from external user sources
 ExternalAuth
     user      UserId
-    source    AuthenticationSourceIdent    -- Identifier of the external source in the config
+    source    AuthSourceIdent              -- Identifier of the external source in the config
     data      Value "default='{}'::jsonb"  -- Raw user data from external source
     lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source? -- TODO rethink
     UniqueExternalAuth user source        -- At most one entry of this user per source
diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index 94edadd84..5747661f6 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -42,16 +42,18 @@ import qualified Data.Text as Text
 import Data.Universe
 import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
+import Data.UUID (UUID)
+import Data.Word (Word16)
 
-import qualified Database.Esqueleto.Legacy as E
 import Database.Persist.Sql
 
-import qualified Ldap.Client as Ldap
-import Ldap.Client.Instances ()
-
 import Servant.Docs (ToSample(..), samples)
 
 
+----------------------------------
+----- Authentication Sources -----
+----------------------------------
+
 type AzureScopes = Set Text
 
 -- Note: Ldap.Host also stores TLS settings, which we will generate ad-hoc based on AuthSourceLdapTls field instead. We therefore use Text to store the hostname only
@@ -68,41 +70,31 @@ type AzureScopes = Set Text
 -- instance E.SqlString LdapPort
 -- makeLenses_ ''LdapPort
 
-newtype LdapPass = LdapPass { ldapPass :: Ldap.Password }
-  deriving (Eq, Ord, Read, Show, Generic, Data)
-  deriving newtype (NFData, PersistField, PersistFieldSql)
-instance E.SqlString LdapPass
-makeLenses_ ''LdapPass
-
-newtype LdapDn = LdapDn { ldapDn :: Ldap.Dn }
-  deriving (Eq, Ord, Read, Show, Generic, Data)
-  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
-instance E.SqlString LdapDn
-makeLenses_ ''LdapDn
-
-newtype LdapScope = LdapScope { ldapScope :: Ldap.Scope }
-  deriving (Eq, Ord, Read, Show, Generic, Data)
-  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
-instance E.SqlString LdapScope
-makeLenses_ ''LdapScope
-
 type UserEduPersonPrincipalName = Text
 
+-- | Subset of the configuration settings of an authentication source that uniquely identify a given source
+-- | Used for uniquely storing ExternalAuth entries per user and source
+data AuthSourceIdent
+  = AuthSourceIdAzure
+    { authSourceIdAzureClientId :: UUID
+    }
+  | AuthSourceIdLdap
+    { authSourceIdLdapHost :: Text    -- See comment above for why we do not use Ldap.Host directly
+    , authSourceIdLdapPort :: Word16  -- See comment above for why we do not use Ldap.PortNumber directly
+    }
+  deriving (Eq, Ord, Read, Show, Data, Generic)
+  deriving anyclass (NFData)
 
--- | Supported protocols for external user sources used for authentication queries
--- TODO: deprecated, delete
-data AuthenticationProtocol
-  = AuthAzure -- ^ Azure ADv2 (OAuth2)
-  | AuthLdap  -- ^ LDAP
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic)
-  deriving anyclass (Universe, Finite, Hashable, NFData)
+deriveJSON defaultOptions
+  { fieldLabelModifier     = camelToPathPiece' 3
+  , constructorTagModifier = camelToPathPiece' 3
+  , sumEncoding            = UntaggedValue
+  } ''AuthSourceIdent
 
-nullaryPathPiece ''AuthenticationProtocol $ camelToPathPiece' 1
-pathPieceJSON ''AuthenticationProtocol
+derivePersistFieldJSON ''AuthSourceIdent
 
-
--- TODO: delete once identification using model table is implemented
-type AuthenticationSourceIdent = Text
+makeLenses_ ''AuthSourceIdent
+makePrisms ''AuthSourceIdent
 
 
 -------------------
@@ -220,6 +212,7 @@ _ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags
 -------------------
 ----- PredDNF -----
 -------------------
+-- TODO: Use external PredDNF instead: https://github.com/savau/haskell-nf
 
 data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
   deriving (Eq, Ord, Read, Show, Data, Generic)

From 71e2d6827ef111626bb83c6292bba3afa4ef31c9 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 02:06:00 +0100
Subject: [PATCH 098/178] chore(model): rename
 userLastLogin->userLastAuthentication for less migration woes

---
 models/users.model           | 4 ++--
 src/Foundation/Yesod/Auth.hs | 4 ++--
 src/Handler/Utils/Users.hs   | 2 +-
 src/Utils/Users.hs           | 2 +-
 4 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/models/users.model b/models/users.model
index 7a2849968..a69e801ef 100644
--- a/models/users.model
+++ b/models/users.model
@@ -14,8 +14,8 @@
 
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
     ident          UserIdent                -- Case-insensitive user-identifier
-    passwordHash   Text Maybe        -- If specified, allows the user to login with credentials independently of external authentication
-    lastLogin      UTCTime Maybe     -- When did the user last authenticate?
+    passwordHash   Text Maybe               -- If specified, allows the user to login with credentials independently of external authentication
+    lastAuthentication UTCTime Maybe        -- When did the user last authenticate?
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 17a64afec..942845cb4 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -117,7 +117,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           -> return ()
       case res of
         Authenticated uid
-          | not isDummy -> res <$ update uid [ UserLastLogin =. Just now ]
+          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
   $logDebugS "Auth" $ tshow Creds{..}
@@ -389,7 +389,7 @@ decodeUser now UserDefaultConf{..} upsertData = do
         , userPinPassword           =  Nothing -- must be derived via AVS
         , userPrefersPostal         =  userDefaultPrefersPostal
         , userPasswordHash          =  Nothing
-        , userLastLogin             =  Nothing
+        , userLastAuthentication    =  Nothing
         , ..
         }
       userUpdate =
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index e906e59d2..14d18c3b2 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -910,7 +910,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   update newUserId $ catMaybes          -- NOTE: persist does shortcircuit null updates as expected
       [ mergeMaybe  UserPasswordHash
-      , mergeBy (>) UserLastLogin
+      , mergeBy (>) UserLastAuthentication
       , mergeBy (<) UserCreated
       , toMaybe (not (validEmail' (newUser ^. _userEmail       )) && validEmail' (oldUser ^. _userEmail))
                 (UserEmail =. oldUser ^. _userEmail)
diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs
index 24c588fb1..20b9bcd37 100644
--- a/src/Utils/Users.hs
+++ b/src/Utils/Users.hs
@@ -44,7 +44,7 @@ addNewUser AddUserData{..} = do
   let 
     newUser = User
       { userIdent                   = audIdent
-      , userLastLogin               = Nothing
+      , userLastAuthentication      = Nothing
       , userPasswordHash            = Nothing
       , userMaxFavourites           = userDefaultMaxFavourites
       , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms

From 012c75db21a5f186cbba007dea00207406a74746 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 02:32:15 +0100
Subject: [PATCH 099/178] chore(pwhash): reintroduce digest computation

---
 src/Handler/Utils/Users.hs               | 14 +++++++-------
 src/Jobs/Handler/SendPasswordReset.hs    |  4 ++--
 templates/mail/userAuthModeUpdate.hamlet |  2 +-
 3 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 14d18c3b2..24b395ca1 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -6,9 +6,9 @@
 
 -- NOTE: Also see Handler.Utils.Profile for similar utilities
 module Handler.Utils.Users
-  ( -- computeUserAuthenticationDigest
-    -- , Digest, SHA3_256
-    constEq
+  ( computeUserAuthenticationDigest
+  , Digest, SHA3_256
+  , constEq
   , NameMatchQuality(..)
   , matchesName
   , GuessUserInfo(..)
@@ -27,13 +27,13 @@ import Import
 import Auth.LDAP (ldapUserMatr')
 import Foundation.Yesod.Auth (upsertUser)
 
--- import Crypto.Hash (hashlazy)
+import Crypto.Hash (hashlazy)
 
 import Data.ByteArray (constEq)
 import Data.Maybe (fromJust)
 import qualified Data.List.NonEmpty as NonEmpty (fromList)
 
--- import qualified Data.Aeson as JSON
+import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
 
 import qualified Data.Set as Set
@@ -130,8 +130,8 @@ getSupervisees = do
   return $ Set.insert uid $ Set.fromAscList svs 
 
 
--- computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
--- computeUserAuthenticationDigest = hashlazy . JSON.encode
+computeUserAuthenticationDigest :: Maybe Text -> Digest SHA3_256
+computeUserAuthenticationDigest = hashlazy . JSON.encode
 
 
 data GuessUserInfo
diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs
index 5a93f3ba3..cf6686d46 100644
--- a/src/Jobs/Handler/SendPasswordReset.hs
+++ b/src/Jobs/Handler/SendPasswordReset.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Winnie Ros 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -36,7 +36,7 @@ dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecip
 
   resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
   let resetBearer = resetBearer'
-        & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
+        & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userPasswordHash)
   encodedBearer <- encodeBearer resetBearer
    
   resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedBearer)])
diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet
index 6fb694a6f..fb45ed4db 100644
--- a/templates/mail/userAuthModeUpdate.hamlet
+++ b/templates/mail/userAuthModeUpdate.hamlet
@@ -41,5 +41,5 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       

         _{SomeMessage MsgAuthExternalLoginTip}
 
-    $if is _Just userLastLogin
+    $if is _Just userLastAuthentication
       ^{editNotifications}

From 19433fdc56dabc113497717b151ad3e0df93df32 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:05:57 +0100
Subject: [PATCH 100/178] chore(profile): better auth info on profile page

---
 src/Handler/Profile.hs       |  2 ++
 templates/profileData.hamlet | 37 +++++++++++++++++++-----------------
 2 files changed, 22 insertions(+), 17 deletions(-)

diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 3a0103c58..4f3c89e90 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -584,6 +584,8 @@ makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   now <- liftIO getCurrentTime
   avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
+  externalAuths <- (\(Entity _ ExternalAuth{..}) -> ("" :: Text, externalAuthSource, externalAuthLastSync)) <<$>> selectList [ ExternalAuthUser ==. uid ] [] -- TODO: define and use user identification in ExternalAuth model
+
   -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
   lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 9eb2817af..881598b6d 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -10,10 +10,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         _{MsgIdent}
       

         #{userIdent}
-      

-        _{MsgAuthModeSet}        
-      
        
-        _{userAuthentication}
       $maybe avs <- avsId
         

           _{MsgAvsPersonNo}
@@ -124,6 +120,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           _{MsgUserCreated}
         

           ^{formatTimeW SelFormatDateTime userCreated}
+        

+          _{MsgAdminUserAuthentication}
+        

+          $if null externalAuths && is _Nothing userPasswordHash
+            _{MsgAuthKindNoLogin}
+          $else
+            
    
+              $if is _Just userPasswordHash
+                
  • _{MsgAuthKindPWHash}
+              $forall (authIdent, sourceIdent, lsync) <- externalAuths
+                
  • 
+                  $case sourceIdent
+                    $of AuthSourceIdAzure _clientId
+                      _{MsgAuthKindAzure}: #
+                    $of AuthSourceIdLdap _host _port
+                      _{MsgAuthKindLDAP}: #
+                  #{authIdent} #
+                  
+                    (_{MsgAdminUserAuthLastSync}: ^{formatTimeW SelFormatDateTime lsync})
         
    
           _{MsgLastLogin}
         
    
@@ -131,18 +146,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             ^{formatTimeW SelFormatDateTime llogin}
           $nothing
             _{MsgNeverSet}
-        
    
-          _{MsgProfileLastLdapSynchronisation}
-        
    
-          $maybe lsync <- userLastLdapSynchronisation
-            ^{formatTimeW SelFormatDateTime lsync}
-          $nothing
-            _{MsgNeverSet}
-        $maybe pKey <- userLdapPrimaryKey
-          
    
-            _{MsgProfileLdapPrimaryKey}
-          
    
-            #{pKey}
         
    
           _{MsgTokensLastReset}
         
    

From 6cd015263691ef7cd45d3a596ef2d1369a7e48ba Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:07:54 +0100
Subject: [PATCH 101/178] refactor(jobs): use new user sync job name

---
 src/Jobs.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Jobs.hs b/src/Jobs.hs
index e24636724..dfb16ee5d 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -71,7 +71,7 @@ import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.Invitation
 import Jobs.Handler.SendPasswordReset
 import Jobs.Handler.TransactionLog
-import Jobs.Handler.SynchroniseUserdb
+import Jobs.Handler.SynchroniseUser
 import Jobs.Handler.SynchroniseAvs
 import Jobs.Handler.PruneInvitations
 import Jobs.Handler.ChangeUserDisplayEmail
@@ -493,7 +493,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
       , Exc.Handler $ \case
           MailNotAvailable -> return $ Right ()
           e                -> return . Left $ SomeException e
-      , Exc.Handler $ \SynchroniseUserdbNoUserdb -> return $ Right () -- TODO
+      , Exc.Handler $ \SynchroniseUserNoSource -> return $ Right ()
 #endif
       , Exc.Handler $ \(e :: SomeException) -> return $ Left e
       ] . fmap Right

From 2490f8e69f7016b63b80e3572ed214ac196ea3c9 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:08:56 +0100
Subject: [PATCH 102/178] chore(users): add password to user data for
 addNewUser

---
 src/Handler/Users/Add.hs | 13 +++++--------
 src/Utils/Users.hs       |  6 ++----
 2 files changed, 7 insertions(+), 12 deletions(-)

diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs
index c168009af..5537c7d8c 100644
--- a/src/Handler/Users/Add.hs
+++ b/src/Handler/Users/Add.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -35,21 +35,18 @@ adminUserForm template = renderAForm FormStandard
   <*> aopt (textField & cfStrip)        (fslI MsgAdminUserPinPassword)      (audPinPassword <$> template)
   <*> areq (emailField & cfCI)          (fslI MsgAdminUserEmail)            (audEmail <$> template)
   <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent)            (audIdent <$> template)
-  <*> areq (selectField optionsFinite)  (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (audAuth <$> template <|> Just AuthKindLDAP)
-  <*> aopt uuidField                    (fslI MsgAdminUserAzureId) (audAzureId <$> template)
+  <*> aopt passwordField                (fslI MsgAdminUserPassword)         (audPassword <$> template)
 
--- | Like `addNewUser`, but starts background jobs and tries to notify users, if applicable (i.e. /= AuthNoLogin )
+-- | Like `addNewUser`, but starts background jobs and tries to notify users
 addNewUserNotify :: AddUserData -> Handler (Maybe UserId)
 addNewUserNotify aud = do
   mbUid <- addNewUser aud
   case mbUid of
     Nothing -> return Nothing
     Just uid -> runDBJobs $ do
-      queueDBJob $ JobSynchroniseUserdbUser uid
-      let authKind = audAuth aud
-      when (authKind /= AuthKindNoLogin) $
+      queueDBJob $ JobSynchroniseUser uid
+      when (is _Just $ audPassword aud) $ do
         queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
-      when (authKind == AuthKindPWHash) $
         queueDBJob $ JobSendPasswordReset uid
       return $ Just uid
 
diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs
index 20b9bcd37..946bfc080 100644
--- a/src/Utils/Users.hs
+++ b/src/Utils/Users.hs
@@ -12,9 +12,6 @@ module Utils.Users
 import Import
 
 
--- TODO: addNewUser might be redundant; use upsertUser instead?
-
-
 data AddUserData = AddUserData
   { audTitle            :: Maybe Text
   , audFirstName        :: Text
@@ -33,6 +30,7 @@ data AddUserData = AddUserData
   , audPinPassword      :: Maybe Text
   , audEmail            :: UserEmail
   , audIdent            :: UserIdent
+  , audPassword         :: Maybe Text
   }
 
 
@@ -45,7 +43,7 @@ addNewUser AddUserData{..} = do
     newUser = User
       { userIdent                   = audIdent
       , userLastAuthentication      = Nothing
-      , userPasswordHash            = Nothing
+      , userPasswordHash            = audPassword
       , userMaxFavourites           = userDefaultMaxFavourites
       , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
       , userTheme                   = userDefaultTheme

From 76d3c57658ae46ee5534a17ff557bd3e848df69a Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:09:18 +0100
Subject: [PATCH 103/178] chore(messages): add and tweak auth messages

---
 messages/uniworx/categories/admin/de-de-formal.msg |  2 +-
 messages/uniworx/categories/admin/en-eu.msg        |  2 +-
 messages/uniworx/categories/user/de-de-formal.msg  | 11 +++++++----
 messages/uniworx/categories/user/en-eu.msg         | 13 ++++++++-----
 4 files changed, 17 insertions(+), 11 deletions(-)

diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg
index d346f9922..bc618283d 100644
--- a/messages/uniworx/categories/admin/de-de-formal.msg
+++ b/messages/uniworx/categories/admin/de-de-formal.msg
@@ -125,4 +125,4 @@ InterfaceLastSynch: Zuletzt
 InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
 
-AdminUserAzureId !ident-ok: Azure-ID
\ No newline at end of file
+AdminUserPassword: Passwort
\ No newline at end of file
diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg
index a01275230..3a2526fc0 100644
--- a/messages/uniworx/categories/admin/en-eu.msg
+++ b/messages/uniworx/categories/admin/en-eu.msg
@@ -125,4 +125,4 @@ InterfaceLastSynch: Last
 InterfaceSubtype: Affecting
 InterfaceWrite: Write
 
-AdminUserAzureId: Azure ID
\ No newline at end of file
+AdminUserPassword: Password
\ No newline at end of file
diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg
index 3b9ee9b1c..b644c1880 100644
--- a/messages/uniworx/categories/user/de-de-formal.msg
+++ b/messages/uniworx/categories/user/de-de-formal.msg
@@ -96,11 +96,14 @@ UserAddSupervisor: Ansprechpartner hinzufügen
 UserSetSupervisor: Ansprechpartner ersetzen
 UserRemoveSupervisor: Alle Ansprechpartner entfernen
 UserIsSupervisor: Ist Ansprechpartner
-AuthKindLDAP: Fraport AG Kennung
-AuthKindAzure: Azure-Login
-AuthKindPWHash: FRADrive Kennung
-AuthKindNoLogin: Kein Login möglich
 Name !ident-ok: Name
 UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
 UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
 UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
+
+AdminUserAuthentication: Authentification
+AdminUserAuthLastSync: Zuletzt synchronisiert
+AuthKindLDAP: Fraport-AG-Kennung (LDAP)
+AuthKindAzure: Azure-Login
+AuthKindPWHash: Interne FRADrive-Kennung
+AuthKindNoLogin: Kein Login möglich
diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg
index 62069247e..c1bd56124 100644
--- a/messages/uniworx/categories/user/en-eu.msg
+++ b/messages/uniworx/categories/user/en-eu.msg
@@ -96,11 +96,14 @@ UserAddSupervisor: Add supervisor
 UserSetSupervisor: Replace supervisors
 UserRemoveSupervisor: Set to unsupervised
 UserIsSupervisor: Is supervisor
-AuthKindLDAP: Fraport AG account
-AuthKindAzure: Azure login
-AuthKindPWHash: FRADrive account
-AuthKindNoLogin: No login
 Name: Name
 UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
-UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
\ No newline at end of file
+UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
+
+AdminUserAuthentication: Authentifizierung
+AdminUserAuthLastSync: Last synchronised
+AuthKindLDAP: Fraport AG account (LDAP)
+AuthKindAzure: Azure account
+AuthKindPWHash: Internal FRADrive login
+AuthKindNoLogin: No login
\ No newline at end of file

From b4a8ccf9ccb3062a93fc712ec5ff88e60d52813b Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:10:19 +0100
Subject: [PATCH 104/178] chore(admin): tweak ldap view

---
 src/Handler/Admin/Ldap.hs | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs
index 27e88eab5..bd18d34e9 100644
--- a/src/Handler/Admin/Ldap.hs
+++ b/src/Handler/Admin/Ldap.hs
@@ -12,11 +12,10 @@ module Handler.Admin.Ldap
 import Import
 -- import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
-import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 -- import qualified Data.Set  as Set
-import Foundation.Yesod.Auth (decodeLdapUserTest,ldapLookupAndUpsert,CampusUserConversionException())
+import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,UserConversionException())
 import Handler.Utils
 
 import qualified Ldap.Client as Ldap
@@ -34,10 +33,10 @@ postAdminLdapR = do
         ldapPool' <- getsYesod $ view _appLdapPool
         case ldapPool' of 
           Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
-          Just ldapPool -> do 
+          Just ldapPool@(ldapConf, _) -> do 
             addMessage Info  $ text2Html "Input for LDAP test received."
-            ldapData <- ldapUser'' ldapPool lid                      
-            decodedErr <- decodeLdapUserTest (pure $ CI.mk lid) $ concat ldapData
+            ldapData <- ldapUser'' ldapPool lid
+            decodedErr <- decodeUserTest UpsertUserDataLdap{ upsertUserLdapConf = ldapConf, upsertUserLdapData = concat ldapData }
             whenIsLeft decodedErr $ addMessageI Error
             return ldapData
   mbLdapData <- formResultMaybe presult procFormPerson
@@ -45,7 +44,7 @@ postAdminLdapR = do
 
   ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-  let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
+  let procFormUpsert :: Text -> Handler (Maybe (Either UserConversionException (Entity User)))
       procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
   mbLdapUpsert <- formResultMaybe uresult procFormUpsert
 

From 55bf8c0355fcef316fd12d982cf0f0dd508834f1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:11:22 +0100
Subject: [PATCH 105/178] chore: add forgotten audPassword

---
 src/Handler/Utils/Avs.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index fbc80bd3e..790479aff 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -460,6 +460,7 @@ upsertAvsUserById api = do
             , audPinPassword      = userPin
             , audEmail = fakeNo    -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
             , audIdent = fakeIdent -- use AvsPersonId instead
+            , audPassword = Nothing
           --, audAuth  = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
             }
       mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe

From 899071e4d6258631e30a1d2a8e8a2ef4667eb356 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:11:59 +0100
Subject: [PATCH 106/178] chore(users): remove eppn support

---
 src/Handler/Course/Users.hs | 6 ------
 src/Handler/Exam/Users.hs   | 7 +------
 2 files changed, 1 insertion(+), 12 deletions(-)

diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index 4a4e11e9d..744ca2671 100644
--- a/src/Handler/Course/Users.hs
+++ b/src/Handler/Course/Users.hs
@@ -204,7 +204,6 @@ data UserTableCsv = UserTableCsv
   , csvUserSex :: Maybe Sex
   , csvUserBirthday :: Maybe Day
   , csvUserMatriculation :: Maybe UserMatriculation
-  , csvUserEPPN :: Maybe UserEduPersonPrincipalName
   , csvUserEmail :: UserEmail
   , csvUserQualifications :: [QualificationName]
   , csvUserSubmissionGroup :: Maybe SubmissionGroupName
@@ -224,7 +223,6 @@ instance Csv.ToNamedRecord UserTableCsv where
     , "sex" Csv..= csvUserSex
     , "birthday" Csv..= csvUserBirthday
     , "matriculation" Csv..= csvUserMatriculation
-    , "eduPersonPrincipalName" Csv..= csvUserEPPN
     , "email" Csv..= csvUserEmail
     , "qualifications" Csv..= CsvSemicolonList csvUserQualifications
     , "submission-group" Csv..= csvUserSubmissionGroup
@@ -286,7 +284,6 @@ data UserTableJson = UserTableJson
   , jsonUserName :: UserDisplayName
   , jsonUserSex :: Maybe (Maybe Sex)
   , jsonUserMatriculation :: Maybe UserMatriculation
-  , jsonUserEPPN :: Maybe UserEduPersonPrincipalName
   , jsonUserEmail :: UserEmail
   , jsonUserQualifications :: Set QualificationName
   , jsonUserSubmissionGroup :: Maybe SubmissionGroupName
@@ -323,7 +320,6 @@ instance ToJSON UserTableJson where
     , pure $ "name" JSON..= jsonUserName
     , ("sex" JSON..=) <$> jsonUserSex
     , ("matriculation" JSON..=) <$> jsonUserMatriculation
-    , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN
     , pure $ "email" JSON..= jsonUserEmail
     , ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications
     , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup
@@ -566,7 +562,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                   <*> view (hasUser . _userSex)
                   <*> view (hasUser . _userBirthday)
                   <*> view (hasUser . _userMatrikelnummer)
-                  <*> view (hasUser . _userLdapPrimaryKey)
                   <*> view (hasUser . _userEmail)
                   <*> (over traverse (qualificationName . entityVal) <$> view _userQualifications)
                   <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
@@ -598,7 +593,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
               <*> view  (hasUser . _userDisplayName)
               <*> views (hasUser . _userSex) (guardOn showSex)
               <*> view  (hasUser . _userMatrikelnummer)
-              <*> view  (hasUser . _userLdapPrimaryKey)
               <*> view  (hasUser . _userEmail)
               <*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal))
               <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index cd06ea982..09e14253f 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -187,7 +187,6 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserFirstName :: Maybe Text
   , csvEUserName :: Maybe Text
   , csvEUserMatriculation :: Maybe Text
-  , csvEUserEPPN :: Maybe UserEduPersonPrincipalName
   , csvEUserStudyFeatures :: UserTableStudyFeatures
   , csvEUserOccurrence :: Maybe (CI Text)
   , csvEUserExercisePoints :: Maybe (Maybe Points)
@@ -208,7 +207,6 @@ instance ToNamedRecord ExamUserTableCsv where
     , "first-name" Csv..= csvEUserFirstName
     , "name" Csv..= csvEUserName
     , "matriculation" Csv..= csvEUserMatriculation
-    , "eduPersonPrincipalName" Csv..= csvEUserEPPN
     , "study-features" Csv..= csvEUserStudyFeatures
     , "occurrence" Csv..= csvEUserOccurrence
     ] ++ catMaybes
@@ -234,7 +232,6 @@ instance FromNamedRecord ExamUserTableCsv where
       <*> csv .:?? "first-name"
       <*> csv .:?? "name"
       <*> csv .:?? "matriculation"
-      <*> csv .:?? "eduPersonPrincipalName"
       <*> pure mempty
       <*> csv .:?? "occurrence"
       <*> fmap Just (csv .:?? "exercise-points")
@@ -277,7 +274,7 @@ examUserTableCsvHeader :: ( MonoFoldable mono
                        => SheetGradeSummary -> Bool -> mono -> Csv.Header
 examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
   [ "surname", "first-name", "name"
-  , "matriculation", "eduPersonPrincipalName"
+  , "matriculation"
   , "study-features"
   , "course-note"
   , "occurrence"
@@ -615,7 +612,6 @@ postEUsersR tid ssh csh examn = do
                 <*> view (resultUser . _entityVal . _userFirstName . to Just)
                 <*> view (resultUser . _entityVal . _userDisplayName . to Just)
                 <*> view (resultUser . _entityVal . _userMatrikelnummer)
-                <*> view (resultUser . _entityVal . _userLdapPrimaryKey)
                 <*> view resultStudyFeatures
                 <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
                 <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped)
@@ -939,7 +935,6 @@ postEUsersR tid ssh csh examn = do
               guessUser' ExamUserTableCsv{..} = do
                 let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
                       [ GuessUserMatrikelnummer <$> csvEUserMatriculation
-                      , GuessUserEduPersonPrincipalName <$> csvEUserEPPN
                       , GuessUserDisplayName <$> csvEUserName
                       , GuessUserSurname <$> csvEUserSurname
                       , GuessUserFirstName <$> csvEUserFirstName

From ad937cda8ccb5d4ff369804c84576cf919ecca9a Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:12:29 +0100
Subject: [PATCH 107/178] chore(users): remove ldap-specific columns in admin
 users page

---
 src/Handler/Users.hs | 109 ++++++++++++++++++++++---------------------
 1 file changed, 56 insertions(+), 53 deletions(-)

diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 0a893e211..b0bad05d8 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -11,14 +11,11 @@ module Handler.Users
 import Import
 
 import Jobs
--- import Data.Text
 import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.Invitations
 import Handler.Utils.Avs
 
-import qualified Auth.LDAP as Auth
-
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Set as Set
@@ -35,8 +32,6 @@ import qualified Data.ByteString.Base64 as Base64
 
 import Data.Aeson hiding (Result(..))
 
--- import Handler.Users.Add as Handler.Users
-
 import qualified Data.Conduit.List as C
 
 import qualified Data.HashSet as HashSet
@@ -130,8 +125,8 @@ postUsersR = do
                 icnReroute = text2widget " " <> toWgt (icon IconLetter)
             pure $ mconcat supervisors
       , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
-      , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication      
-      , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
+      -- , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalAuth
+      -- , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalAuth
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
             schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
@@ -226,15 +221,15 @@ postUsersR = do
           , ( "company-department"
             , SortColumn $ \user -> user E.^. UserCompanyDepartment
             )
-          , ( "auth-ldap"
-            , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
-            )
+          -- , ( "auth-ldap"
+          --   , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
+          --   ) -- TODO: reintroduce via ExternalAuth
           , ( "last-login"
             , SortColumn $ \user -> user E.^. UserLastAuthentication
             )
-          , ( "ldap-sync"
-            , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
-            )
+          -- , ( "ldap-sync"
+          --   , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
+          --   ) -- TODO: reintroduce via ExternalAuth
           , ( "user-company"
             , SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
@@ -276,24 +271,24 @@ postUsersR = do
                  | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
                  | otherwise         -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria
             )
-          , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
-                | Just crit <- getLast criterion
-                  -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
-                | otherwise
-                  -> E.true
-            )
+          -- , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
+          --       | Just crit <- getLast criterion
+          --         -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
+          --       | otherwise
+          --         -> E.true
+          --   ) -- TODO: reintroduce via ExternalAuth
           , ( "school", FilterColumn $ \user criterion -> if
                 | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> let schools = E.valList (Set.toList criterion) in
                     E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
                                                        E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
             )
-          , ( "ldap-sync", FilterColumn $ \user criteria -> if
-                | Just criteria' <- fromNullable criteria
-                  -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
-                      in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
-                | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
-            )
+          -- , ( "ldap-sync", FilterColumn $ \user criteria -> if
+          --       | Just criteria' <- fromNullable criteria
+          --         -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
+          --             in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
+          --       | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
+          --   ) -- TODO: reintroduce via ExternalAuth
           , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
                 E.from $ \(usrComp `E.InnerJoin` comp) -> do 
                   let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@@ -335,8 +330,8 @@ postUsersR = do
           , prismAForm (singletonFilter "user-supervisor")    mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "school")             mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
           , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
-          , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)          
-          , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+          -- , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalAuth
+          -- , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalAuth
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm
@@ -364,7 +359,7 @@ postUsersR = do
       | Set.null usersSet && isNotSetSupervisor act ->
           addMessageI Info MsgActionNoUsersSelected          
     (UserLdapSyncData, userSet) -> do
-      forM_ userSet $ \uid -> queueJob' $ JobSynchroniseUserdbUser uid
+      forM_ userSet $ queueJob' . JobSynchroniseUser
       addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet
       redirectKeepGetParams UsersR
     (UserAvsSyncData, userSet) -> do
@@ -400,7 +395,7 @@ postUsersR = do
 
   formResult allUsersRes $ \case
     AllUsersLdapSync -> do
-      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUserdbUser . entityKey)
+      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey)
       addMessageI Success MsgSynchroniseUserdbAllUsersQueued
       redirect UsersR
   let allUsersWgt' = wrapForm allUsersWgt def
@@ -506,7 +501,7 @@ postAdminUserR uuid = do
           return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
         userAuthenticationForm :: Form ButtonAuthMode
         userAuthenticationForm = buttonForm' $ if
-          | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
+          | is _Nothing userPasswordHash -> [BtnAuthPWHash]
           | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
         systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
           where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
@@ -532,33 +527,41 @@ postAdminUserR uuid = do
           redirect $ AdminUserR uuid
 
         userAuthenticationAction = \case
-          BtnAuthLDAP -> do -- TODO WIP
-            let
-              campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
-              campusHandler _ = mzero
-            campusResult <- runMaybeT . handle campusHandler $ do
-                Just pool <- getsYesod $ view _appLdapPool
-                void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) []
-            case campusResult of
-              Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
-              _other
-                | is _AuthLDAP userAuthentication
-                  -> addMessageI Info MsgAuthLDAPAlreadyConfigured
-              Just () -> do
-                runDBJobs $ do
-                  update uid [ UserAuthentication =. AuthLDAP ]
-                  queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
+          BtnAuthLDAP -> do -- TODO: Reformulate messages and constructors to "remove pw hash" or "external login only"
+            -- let
+            --   ldapHandler :: MonadPlus m => Auth.LdapUserException -> m a
+            --   ldapHandler _ = mzero
+            -- ldapResult <- runMaybeT . handle ldapHandler $ do
+            --     Just pool <- getsYesod $ view _appLdapPool
+            --     void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) []
+            -- case ldapResult of
+            --   Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
+            --   _other
+            --     | is _AuthLDAP userAuthentication
+            --       -> addMessageI Info MsgAuthLDAPAlreadyConfigured
+            --   Just () -> do
+            --     runDBJobs $ do
+            --       update uid [ UserAuthentication =. AuthLDAP ]
+            --       queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
 
+            --     addMessageI Success MsgAuthLDAPConfigured
+            -- TODO: check current auth sources and warn if user cannot login using any source
+            case userPasswordHash of
+              Nothing -> addMessageI Error MsgAuthLDAPAlreadyConfigured
+              Just _ -> do
+                runDBJobs $ do
+                  update uid [ UserPasswordHash =. Nothing ]
+                  queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
                 addMessageI Success MsgAuthLDAPConfigured
             redirect $ AdminUserR uuid
           BtnAuthPWHash -> do
             if
-              | is _AuthPWHash userAuthentication
+              | is _Just userPasswordHash
                 -> addMessageI Info MsgAuthPWHashAlreadyConfigured
               | otherwise
                 -> do
                   runDBJobs $ do
-                    update uid [ UserAuthentication =. AuthPWHash "" ]
+                    update uid [ UserPasswordHash =. Just "" ]
                     queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
                     queueDBJob $ JobSendPasswordReset uid
 
@@ -718,18 +721,18 @@ postUserPasswordR cID = do
   isAdmin <- hasWriteAccessTo $ AdminUserR cID
 
   requireCurrent <- maybeT (return True) $ asum
-    [ False <$ guard (isn't _AuthPWHash userAuthentication)
+    [ False <$ guard (isn't _Just userPasswordHash)
     , False <$ guard isAdmin
     , do
         authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
-        unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
+        unless (authMode `constEq` computeUserAuthenticationDigest userPasswordHash) . lift $
           invalidArgsI [MsgUnauthorizedPasswordResetToken]
         return False
     ]
 
   ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
     currentResult <- if
-      | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
+      | Just (encodeUtf8 -> pwHash) <- userPasswordHash
       , requireCurrent
         -> wreq
              (checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField)
@@ -746,7 +749,7 @@ postUserPasswordR cID = do
 
   formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
     newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
-    liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
+    liftHandler . runDB $ update tUid [ UserPasswordHash =. Just newHash ]
     tell . pure =<< messageI Success MsgPasswordChangedSuccess
 
   siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $

From 87b3214c84d4a20bf270d97c7970074c80cedb6c Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:13:00 +0100
Subject: [PATCH 108/178] chore(lms): fix password in fake user

---
 src/Handler/LMS/Fake.hs | 10 +++-------
 1 file changed, 3 insertions(+), 7 deletions(-)

diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs
index 6276f07bc..67e8ed912 100644
--- a/src/Handler/LMS/Fake.hs
+++ b/src/Handler/LMS/Fake.hs
@@ -67,7 +67,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         let pw = "123.456"
         PWHashConf{..} <- getsYesod $ view _appAuthPWHash
         pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
-        return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
+        return $ TEnc.decodeUtf8 pwHash
     theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
     let addSupervisor = case theSupervisor of 
           [s] -> \suid k -> case k of 
@@ -83,17 +83,13 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool, Int) -> User
         fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal, _isSupervised) =
           let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
+              userPasswordHash = Just pwSimple
+              userLastAuthentication = Nothing
               userEmail = userIdent
               userDisplayEmail = userIdent
               userDisplayName = Text.unwords $ firstNames <> [userSurname]
               userMatrikelnummer = Just "TESTUSER"
-              userAuthentication = pwSimple
-              userLastAuthentication = Nothing
               userCreated = now
-              userLastLdapSynchronisation = Nothing
-              userLdapPrimaryKey = Nothing
-              userLastAzureSynchronisation = Nothing
-              userAzurePrimaryKey = Nothing
               userTokensIssuedAfter = Nothing
               userFirstName = Text.unwords firstNames
               userTitle = Nothing

From 039b1234c5194676f3e79d34a15c61a4775b1db1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:13:51 +0100
Subject: [PATCH 109/178] chore(sap): generalize ldap-cutoff over configured
 ldap sources

---
 src/Handler/SAP.hs | 30 ++++++++++++++++++++++--------
 1 file changed, 22 insertions(+), 8 deletions(-)

diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs
index 4fb8c2c5d..d8a0ac98a 100644
--- a/src/Handler/SAP.hs
+++ b/src/Handler/SAP.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -17,11 +17,9 @@ import Handler.Utils.Csv
 import Handler.Utils.Profile
 
 import qualified Data.Text as Text (intercalate)
--- import qualified Data.CaseInsensitive as CI
 import qualified Data.Csv as Csv
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
--- import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 
@@ -96,8 +94,21 @@ compileBlocks dStart dEnd = go (dStart, True)
 getQualificationSAPDirectR :: Handler TypedContent
 getQualificationSAPDirectR = do
   now   <- liftIO getCurrentTime  
-  fdate <- formatTime' "%Y%m%d_%H-%M" now 
-  let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
+  fdate <- formatTime' "%Y%m%d_%H-%M" now
+  userAuthConf <- getsYesod $ view _appUserAuthConf
+
+  let
+    ldapSources = case userAuthConf of
+      UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
+        -> [ AuthSourceIdLdap
+             { authSourceIdLdapHost = tshow ldapConfHost -- TODO: ugh... what to do in case of tls?
+             , authSourceIdLdapPort = fromInteger $ toInteger ldapConfPort -- TODO: ugh...
+             }
+           ]
+      _other
+        -> mempty
+    ldapCutoff = addDiffDaysRollOver (fromMonths $ -3) now
+
   qualUsers <- runDB $ E.select $ do
     (qual :& qualUser :& user :& qualBlock) <- 
       E.from $ E.table @Qualification 
@@ -111,9 +122,12 @@ getQualificationSAPDirectR = do
           E.&&.   E.val now                         E.>~. qualBlock E.?. QualificationUserBlockFrom
         )
     E.where_ $ E.isJust (qual E.^. QualificationSapId)
-        E.&&.  E.isJust (user E.^. UserCompanyPersonalNumber)
-        E.&&.  E.isJust (user E.^. UserLastLdapSynchronisation)
-        E.&&.  (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
+         E.&&. E.isJust (user E.^. UserCompanyPersonalNumber)
+    E.where_ . E.exists $ do
+      externalAuth <- E.from $ E.table @ExternalAuth
+      E.where_ $ externalAuth E.^. ExternalAuthUser     E.==.  user E.^. UserId
+           E.&&. externalAuth E.^. ExternalAuthSource  `E.in_` E.valList ldapSources
+           E.&&. externalAuth E.^. ExternalAuthLastSync E.>=.  E.val ldapCutoff
     E.groupBy ( user      E.^. UserCompanyPersonalNumber
               , qualUser  E.^. QualificationUserFirstHeld
               , qualUser  E.^. QualificationUserValidUntil                

From a37d4b369a2b8cb169c6de67b3fb482fdbfa8c50 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:14:18 +0100
Subject: [PATCH 110/178] chore(application): rename conf constructors

---
 src/Application.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 9535c36c7..85db6bf07 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -314,14 +314,14 @@ makeFoundation appSettings''@AppSettings{..} = do
 
       -- TODO: reintroduce failover once UserDbFailover is implemented (see above)
       ldapPool <- fmap join . forM appLdapPoolConf $ \ResourcePoolConf{..} -> if
-        | UserSourceConfSingleSource{..} <- appUserSourceConf
-        , UserSourceLdap conf@LdapConf{..} <- usersrcSingleSource
+        | UserAuthConfSingleSource{..} <- appUserAuthConf
+        , AuthSourceConfLdap conf@LdapConf{..} <- userAuthConfSingleSource
           -> do -- set up a singleton ldap pool with no failover
-               let ldapLabel = case ldapHost of
-                     Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
-                     Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
+               let ldapLabel = case ldapConfHost of
+                     Ldap.Plain str -> pack str <> ":" <> tshow ldapConfPort
+                     Ldap.Tls str _ -> pack str <> ":" <> tshow ldapConfPort
                $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
-               Just . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit
+               Just . (conf,) <$> createLdapPool ldapConfHost ldapConfPort poolStripes poolTimeout ldapConfTimeout poolLimit
         | otherwise -- No LDAP pool to be initialized
           -> return Nothing
 
@@ -356,7 +356,7 @@ makeFoundation appSettings''@AppSettings{..} = do
           return . uncurry p $ fromJust mArgs
 
       appAuthPlugins <- liftIO $ sequence [
-          (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
+          (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
         , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2"
         ]
 
@@ -803,7 +803,7 @@ db' = handler' . runDB
 addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
+addPWEntry User{ userPasswordHash = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
   PWHashConf{..} <- getsYesod $ view _appAuthPWHash
-  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
+  (Just . Text.decodeUtf8 -> userPasswordHash) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

From 42ecc91c22b050e6b3046a96a173d5c4799a61b2 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 21 Feb 2024 07:19:37 +0100
Subject: [PATCH 111/178] chore(test): update test database

---
 test/Database/Fill.hs | 69 ++++++++-----------------------------------
 1 file changed, 12 insertions(+), 57 deletions(-)

diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index c2334314b..96b5db828 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -82,7 +82,7 @@ fillDb = do
 
   gkleen <- insert User
     { userIdent  = "G.Kleen@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Just now
     , userTokensIssuedAfter = Just now
     , userMatrikelnummer = Nothing
@@ -103,10 +103,6 @@ fillDb = do
     , userLanguages = Just $ Languages ["en"]
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -124,7 +120,7 @@ fillDb = do
     }
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
@@ -145,10 +141,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
     , userSex = Just SexMale
     , userShowSex = userDefaultShowSex
@@ -168,11 +160,10 @@ fillDb = do
     let pw = "123.456"
     PWHashConf{..} <- getsYesod $ view _appAuthPWHash
     pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
-    return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
+    return $ TEnc.decodeUtf8 pwHash
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
-    -- , userAuthentication = AuthLDAP
-    , userAuthentication = pwSimple
+    , userPasswordHash = Just pwSimple
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "12345678"
@@ -193,10 +184,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userSex = Just SexMale
     , userBirthday = Just $ n_day $ 35 * (-365)
     , userCsvOptions = def
@@ -214,7 +201,7 @@ fillDb = do
     }
   maxMuster <- insert User
     { userIdent  = "max@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Just now
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "1299"
@@ -235,10 +222,6 @@ fillDb = do
     , userLanguages = Just $ Languages ["de"]
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Just $ n_day $ 27 * (-365)
@@ -256,7 +239,7 @@ fillDb = do
     }
   tinaTester <- insert $ User
     { userIdent  = "tester@campus.lmu.de"
-    , userAuthentication = AuthNoLogin
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "999"
@@ -277,10 +260,6 @@ fillDb = do
     , userLanguages = Just $ Languages ["sn"]
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexNotApplicable
     , userBirthday = Just $ n_day 3
@@ -298,7 +277,7 @@ fillDb = do
     }
   svaupel <- insert User
     { userIdent  = "vaupel.sarah@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
@@ -319,10 +298,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexFemale
     , userBirthday = Nothing
@@ -340,7 +315,7 @@ fillDb = do
     }
   sbarth <- insert User
     { userIdent = "Stephan.Barth@campus.lmu.de"
-     , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
@@ -361,10 +336,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -382,7 +353,7 @@ fillDb = do
     }
   _stranger1 <- insert User
     { userIdent = "AVSID:996699"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
@@ -403,10 +374,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -424,7 +391,7 @@ fillDb = do
     }
   _stranger2 <- insert User
     { userIdent = "AVSID:669966"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
@@ -445,10 +412,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -466,7 +429,7 @@ fillDb = do
     }
   _stranger3 <- insert User
     { userIdent = "AVSID:6969"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
@@ -487,10 +450,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
-    , userLastAzureSynchronisation = Nothing
-    , userAzurePrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -546,7 +505,7 @@ fillDb = do
     middlenames = [ Nothing, Just "Jamesson", Just "Theresa", Just "Ally", Just "Tiberius", Just "Maria" ]
     manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
       { userIdent
-      , userAuthentication = AuthLDAP
+      , userPasswordHash = Nothing
       , userLastAuthentication = Nothing
       , userTokensIssuedAfter = Nothing
       , userMatrikelnummer = Just userMatrikelnummer'
@@ -569,10 +528,6 @@ fillDb = do
       , userLanguages = Nothing
       , userNotificationSettings = def
       , userCreated = now
-      , userLastLdapSynchronisation = Nothing
-      , userLdapPrimaryKey = Nothing
-      , userLastAzureSynchronisation = Nothing
-      , userAzurePrimaryKey = Nothing
       , userCsvOptions = def
       , userSex = Nothing
       , userBirthday = Nothing

From bee135ab48d8694eb03b084829db529a195f7cf6 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Thu, 22 Feb 2024 18:56:03 +0000
Subject: [PATCH 112/178] chore(auth): connect azure user lookup

---
 src/Auth/OAuth2.hs | 16 +++++++---------
 1 file changed, 7 insertions(+), 9 deletions(-)

diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 299b6b2e3..6d3847104 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -57,23 +57,21 @@ azureUserPreferredLanguage = "preferredLanguage"
 
 -- | User lookup in Microsoft Graph with given credentials
 azureUser :: ( MonadMask m
-             , MonadUnliftIO m
-          -- , MonadThrow m
+             , MonadHandler m
              )
              => AzureConf
              -> Creds site
              -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])])
-azureUser _conf _creds = fmap throwLeft . liftIO . runExceptT $ do
-  results <- return [] -- TODO
+azureUser _conf Creds{..} = fmap throwLeft . runExceptT $ do
+  results <- queryOAuth2User @[(Text, [ByteString])] credsIdent
   case results of
-    [] -> throwE AzureUserNoResult
-    [res] -> return res
-    _multiple -> throwE AzureUserAmbiguous
+    Left _ -> throwE AzureUserNoResult
+    Right [res] -> return res
+    Right _multiple -> throwE AzureUserAmbiguous
 
 -- | User lookup in Microsoft Graph with given user
 azureUser' :: ( MonadMask m
-              , MonadUnliftIO m
-          -- , MonadThrow m
+              , MonadHandler m
              )
              => AzureConf
              -> User

From 956c85a9f3038b7d213f32e7a34189b1e72013e6 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 28 Feb 2024 11:05:01 +0100
Subject: [PATCH 113/178] chore(migration): remove old ldap-primary-key index

---
 src/Model/Migration/Definitions.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 8e458ac47..b41b8f61b 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -80,7 +80,7 @@ migrateManual = do
     , ("user_lower_ident",                    "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))"                                 )
     , ("submission_sheet",                    "CREATE INDEX submission_sheet ON submission (sheet)"                                      )
     , ("submission_edit_submission",          "CREATE INDEX submission_edit_submission ON submission_edit (submission)"                  )
-    , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        )
+--  , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        ) -- TODO: reintroduce
     , ("file_content_entry_chunk_hash",       "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)"        )
     , ("sent_mail_bounce_secret",             "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
     , ("sent_mail_recipient",                 "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")

From 064645d1b3847c6eeb20dedf3f01ad3ec6a76e2c Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 28 Feb 2024 12:00:06 +0100
Subject: [PATCH 114/178] refactor(ldap): move orphan instance

---
 src/Ldap/Client/Instances.hs | 3 +++
 src/Settings/Ldap.hs         | 4 +---
 2 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs
index 19c1ae6bf..080c84f75 100644
--- a/src/Ldap/Client/Instances.hs
+++ b/src/Ldap/Client/Instances.hs
@@ -10,6 +10,7 @@ module Ldap.Client.Instances
 
 import ClassyPrelude
 
+import Data.Aeson.TH
 import Data.Data (Data)
 
 import Database.Persist.TH (derivePersistField)
@@ -51,3 +52,5 @@ derivePathPiece ''Scope id "--"
 derivePersistField "Dn"
 derivePersistField "Password"
 derivePersistField "Scope"
+
+deriveFromJSON defaultOptions ''Scope
diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs
index 1ef5081be..44d0a4dd9 100644
--- a/src/Settings/Ldap.hs
+++ b/src/Settings/Ldap.hs
@@ -16,11 +16,11 @@ import Utils.Lens.TH
 import Control.Monad.Fail (fail)
 
 import Data.Aeson
-import Data.Aeson.TH
 import qualified Data.Text.Encoding as Text
 import Data.Time.Clock
 
 import qualified Ldap.Client as Ldap
+import Ldap.Client.Instances ()
 
 
 data LdapConf = LdapConf
@@ -36,8 +36,6 @@ data LdapConf = LdapConf
 
 makeLenses_ ''LdapConf
 
-deriveFromJSON defaultOptions ''Ldap.Scope -- TODO: move to Ldap.Client.Instances
-
 instance FromJSON LdapConf where
   parseJSON = withObject "LdapConf" $ \o -> do
     ldapConfTls <- o .:? "tls"

From ac5bca2fcd414e4228e50d6c710e267f4a7de7a3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 28 Feb 2024 15:50:47 +0100
Subject: [PATCH 115/178] chore(ldap): use separate source-id for ldap instance
 identification

---
 src/Handler/SAP.hs           | 9 ++-------
 src/Jobs/HealthReport.hs     | 7 +++++--
 src/Model/Types/Auth.hs      | 4 +---
 src/Settings/Ldap.hs         | 9 +++++++--
 templates/profileData.hamlet | 2 +-
 5 files changed, 16 insertions(+), 15 deletions(-)

diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs
index d8a0ac98a..f7b1eaffa 100644
--- a/src/Handler/SAP.hs
+++ b/src/Handler/SAP.hs
@@ -100,13 +100,8 @@ getQualificationSAPDirectR = do
   let
     ldapSources = case userAuthConf of
       UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
-        -> [ AuthSourceIdLdap
-             { authSourceIdLdapHost = tshow ldapConfHost -- TODO: ugh... what to do in case of tls?
-             , authSourceIdLdapPort = fromInteger $ toInteger ldapConfPort -- TODO: ugh...
-             }
-           ]
-      _other
-        -> mempty
+        -> singleton $ AuthSourceIdLdap ldapConfSourceId
+      _other -> mempty
     ldapCutoff = addDiffDaysRollOver (fromMonths $ -3) now
 
   qualUsers <- runDB $ E.select $ do
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 403a78f4c..04f4f9006 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -110,10 +110,13 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
 dispatchHealthCheckLDAPAdmins :: Handler HealthReport
 dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
   ldapPool' <- getsYesod appLdapPool
---reTestAfter <- getsYesod $ view _appUserdbRetestFailover
+  userAuthConf <- getsYesod $ view _appUserAuthConf
   case ldapPool' of
     Just ldapPool -> do
-      currentLdapSources <- return [] -- TODO: fetch from current user-auth config
+      let currentLdapSources = case userAuthConf of
+            UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
+              -> singleton $ AuthSourceIdLdap ldapConfSourceId
+            _other -> mempty
       ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
         E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
         E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index 5747661f6..fe683f258 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -43,7 +43,6 @@ import Data.Universe
 import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
 import Data.UUID (UUID)
-import Data.Word (Word16)
 
 import Database.Persist.Sql
 
@@ -79,8 +78,7 @@ data AuthSourceIdent
     { authSourceIdAzureClientId :: UUID
     }
   | AuthSourceIdLdap
-    { authSourceIdLdapHost :: Text    -- See comment above for why we do not use Ldap.Host directly
-    , authSourceIdLdapPort :: Word16  -- See comment above for why we do not use Ldap.PortNumber directly
+    { authSourceIdLdapHost :: Text -- normally either just the hostname, or hostname and port
     }
   deriving (Eq, Ord, Read, Show, Data, Generic)
   deriving anyclass (NFData)
diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs
index 44d0a4dd9..ae821f155 100644
--- a/src/Settings/Ldap.hs
+++ b/src/Settings/Ldap.hs
@@ -26,6 +26,7 @@ import Ldap.Client.Instances ()
 data LdapConf = LdapConf
   { ldapConfHost     :: Ldap.Host
   , ldapConfPort     :: Ldap.PortNumber
+  , ldapConfSourceId :: Text -- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port
   , ldapConfDn       :: Ldap.Dn
   , ldapConfPassword :: Ldap.Password
   , ldapConfBase     :: Ldap.Dn
@@ -48,8 +49,12 @@ instance FromJSON LdapConf where
         | null spec          -> return Nothing
       Nothing                -> return Nothing
       _otherwise             -> fail "Could not parse LDAP TLSSettings"
-    ldapConfHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= ""
-    ldapConfPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+    hostname :: Text <- o .: "host"
+    port :: Int <- o .: "port"
+    let
+      ldapConfHost = maybe Ldap.Plain (flip Ldap.Tls) tlsSettings $ show hostname
+      ldapConfPort = fromIntegral port
+    ldapConfSourceId <- o .:? "source-id" .!= hostname
     ldapConfDn <- Ldap.Dn <$> o .:? "user" .!= ""
     ldapConfPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
     ldapConfBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 881598b6d..2b10fa14f 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -134,7 +134,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                   $case sourceIdent
                     $of AuthSourceIdAzure _clientId
                       _{MsgAuthKindAzure}: #
-                    $of AuthSourceIdLdap _host _port
+                    $of AuthSourceIdLdap _sourceId
                       _{MsgAuthKindLDAP}: #
                   #{authIdent} #
                   

From d1e1f25162a3f3d7fc3b5b9987e57ae8249347ff Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 29 Feb 2024 17:52:31 +0100
Subject: [PATCH 116/178] chore(login): use correct auth plugin identifiers for
 comparison in login template

---
 src/Foundation/Instances.hs  |  1 +
 src/Foundation/Yesod/Auth.hs |  4 ++--
 templates/login.hamlet       | 12 ++++++------
 3 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index a217bf91c..f2a87dd9a 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -20,6 +20,7 @@ import qualified Yesod.Core.Unsafe as Unsafe
 import qualified Yesod.Auth.Message as Auth
 
 import Utils.Form
+import Auth.OAuth2 (apAzure, apAzureMock)
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 942845cb4..394f4aed4 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -50,10 +50,10 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
              => Creds UniWorX
              -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
+  $logErrorS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
   setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds)
   sess <- getSession
-  $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
+  $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
 
   now <- liftIO getCurrentTime
   userAuthConf <- getsYesod $ view _appUserAuthConf
diff --git a/templates/login.hamlet b/templates/login.hamlet
index bb3ee704e..cbb45e165 100644
--- a/templates/login.hamlet
+++ b/templates/login.hamlet
@@ -1,28 +1,28 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,David Mosbach 
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , David Mosbach 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 $forall AuthPlugin{apName, apLogin} <- plugins
-  $if apName == "azureadv2"
+  $if apName == apAzure
     
    
       
    Azure
       ^{apLogin toParent}
-  $elseif apName == "dev-oauth2-mock"
+  $elseif apName == apAzureMock
     
    
       
    _{MsgDummyLoginTitle}
       ^{apLogin toParent}
-  $elseif apName == "LDAP"
+  $elseif apName == apLdap
     
    
       
    _{MsgLDAPLoginTitle}
       ^{apLogin toParent}
-  $elseif apName == "PWHash"
+  $elseif apName == apHash
     
    
       
    _{MsgPWHashLoginTitle}
       
    _{MsgPWHashLoginNote}
       ^{apLogin toParent}
-  $elseif apName == "dummy"
+  $elseif apName == apDummy
     
    
       
    _{MsgDummyLoginTitle}
       ^{apLogin toParent}

From 13502d704e172ee99f8c839935388d712036991c Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 29 Feb 2024 22:16:11 +0100
Subject: [PATCH 117/178] refactor(auth): add missing TODOs, remove debris

---
 config/settings.yml          |  12 +-
 src/Foundation/Yesod/Auth.hs | 308 ++---------------------------------
 src/Settings.hs              |  26 ++-
 src/Settings/Ldap.hs         |   7 +-
 src/Settings/OAuth2.hs       |   3 +-
 5 files changed, 34 insertions(+), 322 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index bb8047209..7746c254b 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -66,7 +66,7 @@ keep-unreferenced-files: 86400
 health-check-interval:
   matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
   http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
-  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
+  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
   smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
   widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
   active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60"
@@ -77,7 +77,7 @@ health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can rea
 health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
 health-check-active-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2"
 health-check-smtp-connect-timeout: "_env:HEALTHCHECK_SMTP_CONNECT_TIMEOUT:5"
-health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60"
+health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
 health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2"
 health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2"
 
@@ -129,10 +129,12 @@ database:
 auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
 # External sources used for user authentication and userdata lookups
+# TODO: add SSO option for user-auth config
 user-auth:
 # mode: single-source
   protocol: azureadv2
   config:
+    # TODO make default values obsolete?
     client-id:     "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000"
     client-secret: "_env:AZURECLIENTSECRET:verysecret"
     tenant-id:     "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000"
@@ -149,14 +151,16 @@ user-auth:
     #   timeout:        "_env:LDAPTIMEOUT:5"
     #   search-timeout: "_env:LDAPSEARCHTIME:5"
 
-# TODO: might move later
+# TODO: generalize for arbitrary auth protocols
+# TODO: maybe use separate pools for external databases?
 ldap-pool:
   stripes: "_env:LDAPSTRIPES:1"
   timeout: "_env:LDAPTIMEOUT:20"
   limit:   "_env:LDAPLIMIT:10"
 
-# TODO: might move later
+# TODO: reintroduce and move into failover settings once failover mode has been reimplemented
 # user-retest-failover: 60
+# TODO; maybe implement syncWithin and syncInterval per auth source
 user-sync-within:   "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
 user-sync-interval: "_env:USER_SYNC_INTERVAL:3600"  # jede Stunde
 
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 394f4aed4..bc5092881 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -32,7 +32,6 @@ import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken)
 
 import qualified Control.Monad.Catch as C (Handler(..))
 
--- import qualified Data.Aeson as Json (encode)
 import qualified Data.ByteString as ByteString
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Map as Map
@@ -254,65 +253,6 @@ upsertUser _upsertMode upsertData = do
 
   return user
 
--- | Upsert User DB according to given Azure data (does not query Azure itself)
--- upsertAzureUser :: forall m.
---                     ( MonadHandler m, HandlerSite m ~ UniWorX
---                     , MonadCatch m
---                     )
---                  => UpsertUserMode
---                  -> [(Text, [ByteString])]
---                  -> SqlPersistT m (Entity User)
--- upsertAzureUser upsertMode azureData = do
---   now <- liftIO getCurrentTime
---   userDefaultConf <- getsYesod $ view _appUserDefaults
--- 
---   (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
---   --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
--- 
---   oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
--- 
---   user@(Entity userId userRec) <- case oldUsers of
---     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
---     _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
---   unless (validDisplayName (newUser ^. _userTitle)
---                            (newUser ^. _userFirstName)
---                            (newUser ^. _userSurname)
---                            (userRec ^. _userDisplayName)) $
---     update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
---   when (validEmail' (userRec ^. _userEmail)) $ do
---     let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
---               ++ [ UserAuthentication =. AuthAzure                | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
---     unless (null emUps) $ update userId emUps
---     -- Attempt to update ident, too:
---     unless (validEmail' (userRec ^. _userIdent)) $
---       void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
--- 
---   let
---     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
---     userSystemFunctions' = do
---       (_k, v) <- azureData
---       -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
---       v' <- v
---       Right str <- return $ Text.decodeUtf8' v'
---       assertM' (not . Text.null) $ Text.strip str
--- 
---   iforM_ userSystemFunctions $ \func preset -> do
---     memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
---     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
---        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
--- 
---   return user
-
-decodeUserTest :: ( MonadHandler m
-                  , HandlerSite m ~ UniWorX
-                  , MonadCatch m
-                  )
-               => UpsertUserData
-               -> m (Either UserConversionException (User, [Update User]))
-decodeUserTest decodeData = do
-  now <- liftIO getCurrentTime
-  userDefaultConf <- getsYesod $ view _appUserDefaults
-  try $ decodeUser now userDefaultConf decodeData
 
 decodeUser :: ( MonadThrow m
               )
@@ -445,245 +385,17 @@ decodeUser now UserDefaultConf{..} upsertData = do
     --     | otherwise = throwM err
     --   where
     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--- decodeLdapUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
--- decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
---     let
---       userTelephone             = decodeLdap ldapUserTelephone
---       userMobile                = decodeLdap ldapUserMobile
---       userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
---       userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
--- 
---       userAuthentication
---         | is _UpsertUserLoginOther upsertMode
---                     = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
---         | otherwise = AuthLDAP
---       userLastAuthentication = guardOn isLogin now
---       isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
--- 
---       userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
---       userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
---       userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
---     userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
--- 
---     --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
---     -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
--- 
---     userIdent <- if
---       | [bs] <- ldapMap !!! ldapUserPrincipalName
---       , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
---       , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
---         -> return userIdent'
---       | Just userIdent' <- upsertMode ^? _upsertUserIdent
---         -> return userIdent'
---       | otherwise
---         -> throwM CampusUserInvalidIdent
--- 
---     userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
---       --   | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
---       --      -> return $ CI.mk userEmail
---       | otherwise
---         -> throwM CampusUserInvalidEmail
---         
---     -- TODO: ExternalUser
---     userLdapPrimaryKey <- if
---       | [bs] <- ldapMap !!! ldapPrimaryKey
---       , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
---       , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
---         -> return $ Just userLdapPrimaryKey'''
---       | otherwise
---         -> return Nothing
--- 
---     let
---       newUser = User
---         { userMaxFavourites           = userDefaultMaxFavourites
---         , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
---         , userTheme                   = userDefaultTheme
---         , userDateTimeFormat          = userDefaultDateTimeFormat
---         , userDateFormat              = userDefaultDateFormat
---         , userTimeFormat              = userDefaultTimeFormat
---         , userDownloadFiles           = userDefaultDownloadFiles
---         , userWarningDays             = userDefaultWarningDays
---         , userShowSex                 = userDefaultShowSex
---         , userSex                     = Nothing
---         , userBirthday                = Nothing
---         , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
---         , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
---         , userNotificationSettings    = def
---         , userLanguages               = Nothing
---         , userCsvOptions              = def
---         , userTokensIssuedAfter       = Nothing
---         , userCreated                 = now
---         , userDisplayName             = userDisplayName
---         , userDisplayEmail            = userEmail
---         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
---         , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
---         , userPostLastUpdate          = Nothing
---         , userPinPassword             = Nothing -- must be derived via AVS
---         , userPrefersPostal           = userDefaultPrefersPostal
---         , ..
---         }
---       userUpdate =  
---         [ UserLastAuthentication      =. Just now  | isLogin ] ++
---         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
---         [
---         -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
---           UserFirstName               =. userFirstName
---         , UserSurname                 =. userSurname                    
---         , UserMobile                  =. userMobile
---         , UserTelephone               =. userTelephone
---         , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
---         , UserCompanyDepartment       =. userCompanyDepartment
---         ]
---     return (newUser, userUpdate)
--- 
---   where
---     ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
---     ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
--- 
---     -- just returns Nothing on error, pure
---     decodeLdap :: Ldap.Attr -> Maybe Text
---     decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
--- 
---     decodeLdap' :: Ldap.Attr -> Text
---     decodeLdap' = fromMaybe "" . decodeLdap
---     -- accept the first successful decoding or empty; only throw an error if all decodings fail
---     -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
---     -- decodeLdap' attr err
---     --     | []    <-        vs = return   Nothing
---     --     | (h:_) <- rights vs = return $ Just h
---     --     | otherwise          = throwM err
---     --   where
---     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--- 
---     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
---     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
---     decodeLdap1 attr err
---         | (h:_) <- rights vs  = return h
---         | otherwise           = throwM err
---       where
---         vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--- 
---     -- accept and merge one or more successful decodings, ignoring all others
---     -- decodeLdapN attr err
---     --     | t@(_:_) <- rights vs
---     --       = return $ Text.unwords t
---     --     | otherwise = throwM err
---     --   where
---     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
--- decodeAzureUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_)
--- decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do
---     let
---       userTelephone             = decodeAzure azureUserTelephone
---       userMobile                = decodeAzure azureUserMobile
---       userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer
---       userCompanyDepartment     = Nothing --TODO decodeAzure ldapUserFraportAbteilung
--- 
---       userAuthentication
---         | is _UpsertUserLoginOther upsertMode
---                     = AuthPWHash (error "Non-LDAP logins should only work for users that are already known") -- TODO throwM instead?
---         | otherwise = AuthAzure
---       userLastAuthentication = guardOn isLogin now
---       isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode
--- 
---       userTitle       = Nothing -- TODO decodeAzure  ldapUserTitle     -- CampusUserInvalidTitle
---       userFirstName   = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
---       userSurname     = decodeAzure' azureUserSurname   -- CampusUserInvalidSurname
---     userDisplayName <- decodeAzure1  azureUserDisplayName  UserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
--- 
---     --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
---     -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
--- 
---     userIdent <- if
---       | [bs] <- azureMap !!! azureUserPrincipalName
---       , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
---       , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
---         -> return userIdent'
---       | Just userIdent' <- upsertMode ^? _upsertUserIdent
---         -> return userIdent'
---       | otherwise
---         -> throwM UserInvalidIdent
--- 
---     userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail
---       --      -> return $ CI.mk userEmail
---       | otherwise
---         -> throwM UserInvalidEmail
---         
---     -- TODO: use fromASCIIBytes / fromByteString?
---     userAzurePrimaryKey <- if
---       | [bs] <- azureMap !!! azurePrimaryKey
---       , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs
---       , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey''
---       , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey'''
---         -> return $ Just userAzurePrimaryKey''''
---       | otherwise
---         -> return Nothing
--- 
---     let
---       newUser = User
---         { userMaxFavourites           = userDefaultMaxFavourites
---         , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
---         , userTheme                   = userDefaultTheme
---         , userDateTimeFormat          = userDefaultDateTimeFormat
---         , userDateFormat              = userDefaultDateFormat
---         , userTimeFormat              = userDefaultTimeFormat
---         , userDownloadFiles           = userDefaultDownloadFiles
---         , userWarningDays             = userDefaultWarningDays
---         , userShowSex                 = userDefaultShowSex
---         , userSex                     = Nothing
---         , userBirthday                = Nothing
---         , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
---         , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
---         , userNotificationSettings    = def
---         , userLanguages               = Nothing -- TODO: decode and parse preferredLanguages
---         , userCsvOptions              = def
---         , userTokensIssuedAfter       = Nothing
---         , userCreated                 = now
---         , userDisplayName             = userDisplayName
---         , userDisplayEmail            = userEmail
---         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
---         , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
---         , userPostLastUpdate          = Nothing
---         , userPinPassword             = Nothing -- must be derived via AVS
---         , userPrefersPostal           = userDefaultPrefersPostal
---         , ..
---         }
---       userUpdate =  
---         --- [ UserLastAuthentication      =. Just now  | isLogin ] ++
---         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
---         [
---         -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
---           UserFirstName               =. userFirstName
---         , UserSurname                 =. userSurname
---         , UserMobile                  =. userMobile
---         , UserTelephone               =. userTelephone
---         , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
---         , UserCompanyDepartment       =. userCompanyDepartment
---         ]
---     return (newUser, userUpdate)
--- 
---   where
---     azureMap :: Map.Map Text [ByteString]
---     azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null))
--- 
---     -- just returns Nothing on error, pure
---     decodeAzure :: Text -> Maybe Text
---     decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr
--- 
---     decodeAzure' :: Text -> Text
---     decodeAzure' = fromMaybe "" . decodeAzure
--- 
---     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
---     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
---     decodeAzure1 attr err
---         | (h:_) <- rights vs  = return h
---         | otherwise           = throwM err
---       where
---         vs = Text.decodeUtf8' <$> (azureMap !!! attr)
+decodeUserTest :: ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  )
+               => UpsertUserData
+               -> m (Either UserConversionException (User, [Update User]))
+decodeUserTest decodeData = do
+  now <- liftIO getCurrentTime
+  userDefaultConf <- getsYesod $ view _appUserDefaults
+  try $ decodeUser now userDefaultConf decodeData
 
 
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
diff --git a/src/Settings.hs b/src/Settings.hs
index 74a07929b..9aa46f6b1 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -47,8 +47,6 @@ import qualified Data.Scientific as Scientific
 
 import qualified Data.Text as Text
 
--- import qualified Ldap.Client as Ldap
-
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
 import qualified Network.Socket as HaskellNet
 
@@ -78,8 +76,6 @@ import qualified Web.ServerSession.Core as ServerSession
 
 import Text.Show (showParen, showString)
 
--- import qualified Data.List.PointedList as P
-
 import qualified Network.Minio as Minio
 
 import Data.Conduit.Algorithms.FastCDC
@@ -451,12 +447,11 @@ data AppSettings = AppSettings
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
-    , appUserAuthConf           :: UserAuthConf
-    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
+    , appUserAuthConf           :: UserAuthConf -- TODO: add SSO option for user-auth config
     , appLmsConf                :: LmsConf
-    -- ^ Configuration settings for accessing the LDAP-directory
+    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) -- TODO, TODISCUSS: reimplement as user-auth source?
     , appAvsConf                :: Maybe AvsConf
-    -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
+    -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) -- TODO, TODISCUSS: reimplement as user-auth source?
     , appLprConf                :: LprConf
     -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
     , appSmtpConf               :: Maybe SmtpConf
@@ -464,15 +459,13 @@ data AppSettings = AppSettings
     , appWidgetMemcachedConf    :: Maybe WidgetMemcachedConf
     -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
     , appRoot                   :: ApprootScope -> Maybe Text
-    -- ^ Base for all generated URLs. If @Nothing@, determined
-    -- from the request headers.
+    -- ^ Base for all generated URLs. If @Nothing@, determined from the request headers.
     , appHost                   :: HostPreference
     -- ^ Host/interface the server should bind to.
     , appPort                   :: Int
     -- ^ Port to listen on
     , appIpFromHeader           :: Bool
-    -- ^ Get the IP address from the header when logging. Useful when sitting
-    -- behind a reverse proxy.
+    -- ^ Get the IP address from the header when logging. Useful when sitting behind a reverse proxy.
 
     , appServerSessionConfig    :: ServerSessionSettings
     , appServerSessionAcidFallback :: Bool
@@ -513,15 +506,17 @@ data AppSettings = AppSettings
     , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
     , appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime
     , appHealthCheckSMTPConnectTimeout :: NominalDiffTime
-    , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime
+    , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime -- TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
     , appHealthCheckHTTPReachableTimeout :: NominalDiffTime
     , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime
 
-    -- , appUserRetestFailover :: DiffTime
+    -- , appUserRetestFailover :: DiffTime -- TODO: reintroduce and move into failover settings once failover mode has been reimplemented
+    -- TODO; maybe implement syncWithin and syncInterval per auth source
     , appUserSyncWithin     :: Maybe NominalDiffTime
     , appUserSyncInterval   :: NominalDiffTime
 
-    , appLdapPoolConf :: Maybe ResourcePoolConf
+    , appLdapPoolConf :: Maybe ResourcePoolConf -- TODO: generalize for arbitrary auth protocols
+                                                -- TODO: maybe use separate pools for external databases?
 
     , appSynchroniseAvsUsersWithin   :: Maybe NominalDiffTime
     , appSynchroniseAvsUsersInterval :: NominalDiffTime
@@ -624,6 +619,7 @@ instance FromJSON AppSettings where
         appWebpackEntrypoints     <- o .: "webpack-manifest"
         appDatabaseConf           <- o .: "database"
         appAutoDbMigrate          <- o .: "auto-db-migrate"
+        -- TODO: reintroduce non-emptyness check for ldap hosts
         -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
         --       Ldap.Tls host _ -> not $ null host
         --       Ldap.Plain host -> not $ null host
diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs
index ae821f155..915f4ebce 100644
--- a/src/Settings/Ldap.hs
+++ b/src/Settings/Ldap.hs
@@ -2,11 +2,9 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Settings.Ldap
   ( LdapConf(..)
-  , _ldapConfHost, _ldapConfDn, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout
+  , _ldapConfHost, _ldapConfPort, _ldapConfSourceId, _ldapConfDn, _ldapConfPassword, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout
   ) where
 
 import ClassyPrelude
@@ -26,7 +24,8 @@ import Ldap.Client.Instances ()
 data LdapConf = LdapConf
   { ldapConfHost     :: Ldap.Host
   , ldapConfPort     :: Ldap.PortNumber
-  , ldapConfSourceId :: Text -- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port
+  , ldapConfSourceId :: Text
+  -- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port
   , ldapConfDn       :: Ldap.Dn
   , ldapConfPassword :: Ldap.Password
   , ldapConfBase     :: Ldap.Dn
diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs
index 5242a776a..ba1980178 100644
--- a/src/Settings/OAuth2.hs
+++ b/src/Settings/OAuth2.hs
@@ -22,7 +22,8 @@ data AzureConf = AzureConf
   , azureConfClientSecret :: Text
   , azureConfTenantId     :: UUID
   , azureConfScopes       :: Set Text -- TODO: use AzureScopes type?
-  } deriving (Show)
+  }
+  deriving (Show)
 
 makeLenses_ ''AzureConf
 

From 40fe8ecfc6113db3a1fcca2cacfa330773739d08 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 1 Mar 2024 10:47:52 +0100
Subject: [PATCH 118/178] chore(model): remigrate ExternalAuth -> ExternalUser
 for more general data lookup; redefine lastSync timestamp semantics

---
 models/auth.model  | 13 -------------
 models/users.model | 10 ++++++++++
 2 files changed, 10 insertions(+), 13 deletions(-)
 delete mode 100644 models/auth.model

diff --git a/models/auth.model b/models/auth.model
deleted file mode 100644
index 4582ab43d..000000000
--- a/models/auth.model
+++ /dev/null
@@ -1,13 +0,0 @@
--- SPDX-FileCopyrightText: 2024 Sarah Vaupel 
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
--- TODO: define AuthenticationSource with json instances to store unique source identifiers per protocol
--- | User authentication data fetched from external user sources
-ExternalAuth
-    user      UserId
-    source    AuthSourceIdent              -- Identifier of the external source in the config
-    data      Value "default='{}'::jsonb"  -- Raw user data from external source
-    lastSync  UTCTime                      -- When was the corresponding User entry last synced with this external source? -- TODO rethink
-    UniqueExternalAuth user source        -- At most one entry of this user per source
-    deriving Show Eq Ord Generic
diff --git a/models/users.model b/models/users.model
index a69e801ef..c8611022e 100644
--- a/models/users.model
+++ b/models/users.model
@@ -49,10 +49,20 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
+    lastSync              UTCTime Maybe         -- When was the User data last synchronised with external sources?
     UniqueAuthentication  ident                 -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
+-- | User data fetched from external user sources, used for authentication and data queries
+ExternalUser
+    user      UserId
+    source    AuthSourceIdent              -- Identifier of the external source in the config
+    data      Value "default='{}'::jsonb"  -- Raw user data from external source -- TODO: maybe make Maybe, iff the source only ever responds with "success"?
+    lastSync  UTCTime                      -- When was the external source last queried?
+    UniqueExternalUser user source         -- At most one entry of this user per source
+    deriving Show Eq Ord Generic
+
 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
     user     UserId
     school   SchoolId

From f88e527fe4be175b1c8909b6070dfdb79c5b8ab5 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 1 Mar 2024 12:03:38 +0100
Subject: [PATCH 119/178] chore(model): remigrate ExternalAuth -> ExternalUser
 for more general data lookup; redefine lastSync timestamp semantics contd

---
 src/Foundation/Authorization.hs |  2 +-
 src/Foundation/Yesod/Auth.hs    |  4 +++-
 src/Handler/LMS/Fake.hs         |  1 +
 src/Handler/Profile.hs          |  2 +-
 src/Handler/SAP.hs              |  8 ++++----
 src/Handler/Users.hs            | 16 ++++++++--------
 src/Jobs/HealthReport.hs        |  6 +++---
 src/Model/Types/Auth.hs         |  2 +-
 src/Utils/Users.hs              |  1 +
 templates/profileData.hamlet    |  4 ++--
 test/Database/Fill.hs           | 11 +++++++++++
 11 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index b85e397d7..de4575a8d 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -1534,7 +1534,7 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu
   let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
   maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
     Entity uid _ <- MaybeT $ getEntity referencedUser'
-    guardM . lift $ exists [ ExternalAuthUser ==. uid, ExternalAuthSource <-. availableSources ]
+    guardM . lift $ exists [ ExternalUserUser ==. uid, ExternalUserSource <-. availableSources ]
   return Authorized
 tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index bc5092881..d80405f60 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -321,7 +321,6 @@ decodeUser now UserDefaultConf{..} upsertData = do
         , userNotificationSettings  =  def
         , userCsvOptions            =  def
         , userTokensIssuedAfter     =  Nothing
-        , userCreated               =  now
         , userDisplayEmail          =  userEmail
         , userMatrikelnummer        =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
         , userPostAddress           =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
@@ -330,6 +329,8 @@ decodeUser now UserDefaultConf{..} upsertData = do
         , userPrefersPostal         =  userDefaultPrefersPostal
         , userPasswordHash          =  Nothing
         , userLastAuthentication    =  Nothing
+        , userCreated               =  now
+        , userLastSync              =  Just now
         , ..
         }
       userUpdate =
@@ -341,6 +342,7 @@ decodeUser now UserDefaultConf{..} upsertData = do
         , UserMobile                =. userMobile
         , UserCompanyPersonalNumber =. userCompanyPersonalNumber
         , UserCompanyDepartment     =. userCompanyDepartment
+        , UserLastSync              =. Just now
         ]
     return (newUser, userUpdate)
 
diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs
index 67e8ed912..743f076f8 100644
--- a/src/Handler/LMS/Fake.hs
+++ b/src/Handler/LMS/Fake.hs
@@ -90,6 +90,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
               userDisplayName = Text.unwords $ firstNames <> [userSurname]
               userMatrikelnummer = Just "TESTUSER"
               userCreated = now
+              userLastSync = Just now
               userTokensIssuedAfter = Nothing
               userFirstName = Text.unwords firstNames
               userTitle = Nothing
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 4f3c89e90..8365d8b07 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -584,7 +584,7 @@ makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   now <- liftIO getCurrentTime
   avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
-  externalAuths <- (\(Entity _ ExternalAuth{..}) -> ("" :: Text, externalAuthSource, externalAuthLastSync)) <<$>> selectList [ ExternalAuthUser ==. uid ] [] -- TODO: define and use user identification in ExternalAuth model
+  externalUsers <- (\(Entity _ ExternalUser{..}) -> ("" :: Text, externalUserSource, externalUserLastSync)) <<$>> selectList [ ExternalUserUser ==. uid ] [] -- TODO: define and use user identification in ExternalUser model
 
   -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs
index f7b1eaffa..a04ba50ab 100644
--- a/src/Handler/SAP.hs
+++ b/src/Handler/SAP.hs
@@ -119,10 +119,10 @@ getQualificationSAPDirectR = do
     E.where_ $ E.isJust (qual E.^. QualificationSapId)
          E.&&. E.isJust (user E.^. UserCompanyPersonalNumber)
     E.where_ . E.exists $ do
-      externalAuth <- E.from $ E.table @ExternalAuth
-      E.where_ $ externalAuth E.^. ExternalAuthUser     E.==.  user E.^. UserId
-           E.&&. externalAuth E.^. ExternalAuthSource  `E.in_` E.valList ldapSources
-           E.&&. externalAuth E.^. ExternalAuthLastSync E.>=.  E.val ldapCutoff
+      externalUser <- E.from $ E.table @ExternalUser
+      E.where_ $ externalUser E.^. ExternalUserUser     E.==.  user E.^. UserId
+           E.&&. externalUser E.^. ExternalUserSource  `E.in_` E.valList ldapSources
+           E.&&. externalUser E.^. ExternalUserLastSync E.>=.  E.val ldapCutoff
     E.groupBy ( user      E.^. UserCompanyPersonalNumber
               , qualUser  E.^. QualificationUserFirstHeld
               , qualUser  E.^. QualificationUserValidUntil                
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index b0bad05d8..d29bbd82d 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -125,8 +125,8 @@ postUsersR = do
                 icnReroute = text2widget " " <> toWgt (icon IconLetter)
             pure $ mconcat supervisors
       , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
-      -- , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalAuth
-      -- , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalAuth
+      -- , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalUser
+      -- , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalUser
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
             schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
@@ -223,13 +223,13 @@ postUsersR = do
             )
           -- , ( "auth-ldap"
           --   , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
-          --   ) -- TODO: reintroduce via ExternalAuth
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "last-login"
             , SortColumn $ \user -> user E.^. UserLastAuthentication
             )
           -- , ( "ldap-sync"
           --   , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
-          --   ) -- TODO: reintroduce via ExternalAuth
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "user-company"
             , SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
@@ -276,7 +276,7 @@ postUsersR = do
           --         -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
           --       | otherwise
           --         -> E.true
-          --   ) -- TODO: reintroduce via ExternalAuth
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "school", FilterColumn $ \user criterion -> if
                 | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> let schools = E.valList (Set.toList criterion) in
@@ -288,7 +288,7 @@ postUsersR = do
           --         -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
           --             in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
           --       | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
-          --   ) -- TODO: reintroduce via ExternalAuth
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
                 E.from $ \(usrComp `E.InnerJoin` comp) -> do 
                   let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@@ -330,8 +330,8 @@ postUsersR = do
           , prismAForm (singletonFilter "user-supervisor")    mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "school")             mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
           , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
-          -- , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalAuth
-          -- , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalAuth
+          -- , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalUser
+          -- , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalUser
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 04f4f9006..0752cac76 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -120,9 +120,9 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
       ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
         E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
         E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
-        E.where_ . E.exists . E.from $ \externalAuth -> E.where_ $
-                externalAuth E.^. ExternalAuthUser E.==. user E.^. UserId
-          E.&&. externalAuth E.^. ExternalAuthSource `E.in_` E.valList currentLdapSources
+        E.where_ . E.exists . E.from $ \externalUser -> E.where_ $
+                externalUser E.^. ExternalUserUser E.==. user E.^. UserId
+          E.&&. externalUser E.^. ExternalUserSource `E.in_` E.valList currentLdapSources
         return $ user E.^. UserIdent
       for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
         let numAdmins = genericLength ldapAdminUsers
diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index fe683f258..add176291 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -72,7 +72,7 @@ type AzureScopes = Set Text
 type UserEduPersonPrincipalName = Text
 
 -- | Subset of the configuration settings of an authentication source that uniquely identify a given source
--- | Used for uniquely storing ExternalAuth entries per user and source
+-- | Used for uniquely storing ExternalUser entries per user and source
 data AuthSourceIdent
   = AuthSourceIdAzure
     { authSourceIdAzureClientId :: UUID
diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs
index 946bfc080..7c676299a 100644
--- a/src/Utils/Users.hs
+++ b/src/Utils/Users.hs
@@ -77,5 +77,6 @@ addNewUser AddUserData{..} = do
       , userPrefersPostal           = audPrefersPostal
       , userPinPassword             = audPinPassword
       , userMatrikelnummer          = audMatriculation
+      , userLastSync                = Nothing -- TODO: combine add user with external sync?
       }
   runDB $ insertUnique newUser
\ No newline at end of file
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 2b10fa14f..1501f3c53 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -123,13 +123,13 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         
    
           _{MsgAdminUserAuthentication}
         
    
-          $if null externalAuths && is _Nothing userPasswordHash
+          $if null externalUsers && is _Nothing userPasswordHash
             _{MsgAuthKindNoLogin}
           $else
             
      
               $if is _Just userPasswordHash
                 
    • _{MsgAuthKindPWHash}
-              $forall (authIdent, sourceIdent, lsync) <- externalAuths
+              $forall (authIdent, sourceIdent, lsync) <- externalUsers
                 
    • 
                   $case sourceIdent
                     $of AuthSourceIdAzure _clientId
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 96b5db828..8808ebc87 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -84,6 +84,7 @@ fillDb = do
     { userIdent  = "G.Kleen@campus.lmu.de"
     , userPasswordHash = Nothing
     , userLastAuthentication = Just now
+    , userLastSync = Just now
     , userTokensIssuedAfter = Just now
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
@@ -122,6 +123,7 @@ fillDb = do
     { userIdent  = "felix.hamann@campus.lmu.de"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "noEmailKnown"
@@ -165,6 +167,7 @@ fillDb = do
     { userIdent  = "jost@tcs.ifi.lmu.de"
     , userPasswordHash = Just pwSimple
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "12345678"
     , userEmail  = "S.Jost@Fraport.de"
@@ -203,6 +206,7 @@ fillDb = do
     { userIdent  = "max@campus.lmu.de"
     , userPasswordHash = Nothing
     , userLastAuthentication = Just now
+    , userLastSync = Just now
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "1299"
     , userEmail  = "max@campus.lmu.de"
@@ -241,6 +245,7 @@ fillDb = do
     { userIdent  = "tester@campus.lmu.de"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "999"
     , userEmail  = "tester@campus.lmu.de"
@@ -279,6 +284,7 @@ fillDb = do
     { userIdent  = "vaupel.sarah@campus.lmu.de"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "vaupel.sarah@campus.lmu.de"
@@ -317,6 +323,7 @@ fillDb = do
     { userIdent = "Stephan.Barth@campus.lmu.de"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "Stephan.Barth@lmu.de"
@@ -355,6 +362,7 @@ fillDb = do
     { userIdent = "AVSID:996699"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "E996699@fraport.de"
@@ -393,6 +401,7 @@ fillDb = do
     { userIdent = "AVSID:669966"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "E669966@fraport.de"
@@ -431,6 +440,7 @@ fillDb = do
     { userIdent = "AVSID:6969"
     , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "E6969@fraport.de"
@@ -507,6 +517,7 @@ fillDb = do
       { userIdent
       , userPasswordHash = Nothing
       , userLastAuthentication = Nothing
+      , userLastSync = Nothing
       , userTokensIssuedAfter = Nothing
       , userMatrikelnummer = Just userMatrikelnummer'
       , userEmail        = userEmail'

From 434eed2217321b5fea20de5340c3543f9093994b Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 1 Mar 2024 20:42:51 +0100
Subject: [PATCH 120/178] chore(auth): do not authenticate against external
 sources on dummy login

---
 src/Foundation/Yesod/Auth.hs | 44 ++++++++++++++++++------------------
 1 file changed, 22 insertions(+), 22 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index d80405f60..b9283124d 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -105,7 +105,6 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           excRecovery . ServerError $ mr cExc
       ]
 
-    -- | Authenticate already existing ExternalUser entries only
     acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
     acceptExisting = do
       res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
@@ -121,19 +120,21 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
   $logDebugS "Auth" $ tshow Creds{..}
 
-  flip catches excHandlers $ case userAuthConf of
-    UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf)
-      | Just upsertMode' <- upsertMode -> do
-          upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
-          $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
-          Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
-    UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf)
-      | Just upsertMode' <- upsertMode -> do
-          ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-          upsertUserLdapData <- ldapUser ldapPool Creds{..}
-          $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
-          Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
-    _other
+  flip catches excHandlers $ if
+    | not isDummy, not isOther
+    , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
+    , Just upsertMode' <- upsertMode -> do
+        upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
+        $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
+        Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
+    | not isDummy, not isOther
+    , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
+    , Just upsertMode' <- upsertMode -> do
+        ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
+        upsertUserLdapData <- ldapUser ldapPool Creds{..}
+        $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
+        Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
+    | otherwise
       -> acceptExisting
 
 
@@ -150,7 +151,6 @@ data UserConversionException
   deriving anyclass (Exception)
 
 
--- TODO: this is probably not a sane traversal anymore...
 _upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
 _upsertUserMode mMode cs@Creds{..}
   | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
@@ -159,15 +159,15 @@ _upsertUserMode mMode cs@Creds{..}
   | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
   where
     setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
-      = cs{ credsPlugin = upsertUserSource }
+      = cs { credsPlugin = upsertUserSource }
     setMode UpsertUserLoginDummy{..}
-      = cs{ credsPlugin = apDummy
-          , credsIdent  = CI.original upsertUserIdent
-          }
+      = cs { credsPlugin = apDummy
+           , credsIdent  = CI.original upsertUserIdent
+           }
     setMode UpsertUserLoginOther{..}
-      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
-          , credsIdent  = CI.original upsertUserIdent
-          }
+      = cs { credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
+           , credsIdent  = CI.original upsertUserIdent
+           }
     setMode _ = cs
 
     loginAPs = [ apAzure, apLdap ]

From 4ff51c8f6f48f22a8b4f7ca0c81bc2c38d43b32a Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 3 Mar 2024 04:35:39 +0100
Subject: [PATCH 121/178] chore: add TODOs and debug logs

---
 models/users.model           | 2 +-
 src/Foundation/Yesod/Auth.hs | 1 +
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/models/users.model b/models/users.model
index c8611022e..fdbdb6fcf 100644
--- a/models/users.model
+++ b/models/users.model
@@ -56,7 +56,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
 
 -- | User data fetched from external user sources, used for authentication and data queries
 ExternalUser
-    user      UserId
+    user      UserId -- TODO: use UserIdent or Text instead; not every external user may have ever logged in (or needs to), i.e. users that have been queried in admin handler!
     source    AuthSourceIdent              -- Identifier of the external source in the config
     data      Value "default='{}'::jsonb"  -- Raw user data from external source -- TODO: maybe make Maybe, iff the source only ever responds with "success"?
     lastSync  UTCTime                      -- When was the external source last queried?
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index b9283124d..69a967e00 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -56,6 +56,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
   now <- liftIO getCurrentTime
   userAuthConf <- getsYesod $ view _appUserAuthConf
+  $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only
 
   let
     uAuth = UniqueAuthentication $ CI.mk credsIdent

From 2196e892083ff1aba22fbede00df62b3a62616f1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 3 Mar 2024 04:36:18 +0100
Subject: [PATCH 122/178] chore(settings): define more sane default values in
 settings.yml

---
 config/settings.yml | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 7746c254b..36a0094e3 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -134,11 +134,10 @@ user-auth:
 # mode: single-source
   protocol: azureadv2
   config:
-    # TODO make default values obsolete?
     client-id:     "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000"
-    client-secret: "_env:AZURECLIENTSECRET:verysecret"
+    client-secret: "_env:AZURECLIENTSECRET:''"
     tenant-id:     "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000"
-    scopes:        "_env:AZURESCOPES:[]"
+    scopes:        "_env:AZURESCOPES:[ID,Profile]"
     # protocol: "ldap"
     # config:
     #   host:           "_env:LDAPHOST:"

From bb03d28b7dd5827a15beffdcaebeab5548b23daf Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Sun, 3 Mar 2024 06:16:53 +0100
Subject: [PATCH 123/178] chore(auth): actually use user-auth config for
 determining auth plugins to load

---
 src/Application.hs | 33 ++++++++++++++++++++++-----------
 1 file changed, 22 insertions(+), 11 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 85db6bf07..76d56defd 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -60,7 +60,6 @@ import System.Directory
 import Jobs
 
 import qualified Data.Text.Encoding as Text
-import qualified Data.Text as Text
 
 import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped)
 import Yesod.Auth.Util.PasswordStore
@@ -344,21 +343,33 @@ makeFoundation appSettings''@AppSettings{..} = do
       appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool
       appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool
 
-
-      mAzureTenantID <- liftIO $ (fmap Text.pack) <$> (return $ Just "123") -- lookupEnv "AZURE_ADV2_TENANT_ID"
+      -- TODO: either migrate these to Foundation.Instances, or migrate additions in Foundation.Instances here
+      -- TODO: use scopes from Settings
+#ifdef DEVELOPMENT
+      oauth2Plugins <- liftIO $ sequence
+        [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
+        , return $ oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] "42" "42" "shhh"
+        ]
+#else
       let -- Auth Plugins
-        tenantID = fromMaybe (error "Tenant ID mising") mAzureTenantID
         loadPlugin p prefix = do -- Loads given YesodAuthPlugin
-          mID <- (fmap Text.pack) <$> (return $ Just "UWX") -- (lookupEnv $ prefix ++ "_CLIENT_ID")
-          mSecret <- (fmap Text.pack) <$> (return $ Just prefix) -- (lookupEnv $ prefix ++ "_CLIENT_SECRET")
+          mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzure . _azureConfClientId
+          mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzure . _azureConfClientSecret
           let mArgs = (,) <$> mID <*> mSecret
           guard $ isJust mArgs
           return . uncurry p $ fromJust mArgs
-
-      appAuthPlugins <- liftIO $ sequence [
-          (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
-        , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2"
-        ]
+        tenantID = case appUserAuthConf of
+          UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..})
+            -> Text.pack azureConfTenantId
+          _other
+            -> error "Tenant ID missing!"
+        oauth2Plugins
+          | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
+            -> singleton $ oauth2AzureADv2Scoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
+          | otherwise
+            -> mempty
+#endif
+      let appAuthPlugins = oauth2Plugins
 
 
       let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns

From fbe0e37d281e19bcdbb926eb9a128c69186dd596 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Tue, 5 Mar 2024 23:57:10 +0000
Subject: [PATCH 124/178] feat(auth): oidc based sso for auth protected routes

---
 config/settings.yml         |  4 +++-
 src/Auth/OAuth2.hs          | 22 ++++++++++++++--------
 src/Foundation/Instances.hs | 21 ++++++++++++++-------
 src/Settings.hs             |  5 ++++-
 4 files changed, 35 insertions(+), 17 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 602c9c0e2..28858440b 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt 
+# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -131,6 +131,8 @@ database:
 
 auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
+single-sign-on: "_env:OIDC_SSO:true"
+
 ldap:
   - host:    "_env:LDAPHOST:"
     tls:     "_env:LDAPTLS:"
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index fab04ca16..613a1ddd5 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -8,7 +8,7 @@ module Auth.OAuth2
 ( AzureUserException(..)
 , azurePluginName
 , oauth2MockServer
-, mockPluginName 
+, mockPluginName
 , queryOAuth2User
 , UserDataException
 ) where
@@ -36,9 +36,9 @@ instance Exception AzureUserException
 azurePluginName :: Text
 azurePluginName = "azureadv2"
 
-----------------------------------------
----- OAuth2 development auth plugin ----
-----------------------------------------
+-----------------------------------------------
+---- OAuth2 + OIDC development auth plugin ----
+-----------------------------------------------
 
 mockPluginName :: Text
 mockPluginName = "dev-oauth2-mock"
@@ -53,7 +53,11 @@ oauth2MockServer port =
   let oa = OAuth2
             { oauth2ClientId = "42"
             , oauth2ClientSecret = Just "shhh"
-            , oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth") `withQuery` [scopeParam " " ["ID", "Profile"]]
+            , oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth")
+              `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
+                          , ("response_type", "code id_token")
+                          , ("nonce", "Foo") -- TODO generate meaningful value
+                          ]
             , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
             , oauth2RedirectUri = Nothing
             }
@@ -94,7 +98,8 @@ queryOAuth2User userID = runExceptT $ do
   setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens)
   eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req
     { secure = secure
-    , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] })
+    , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)]
+    })
   case eResult of
     Left x -> throwE $ UserDataJSONException x
     Right x -> return x
@@ -130,8 +135,8 @@ refreshOAuth2Token (_, rToken) url secure
     body' <- if secure then do
         clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID"
         clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET"
-        return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")]
-      else return $ ("scope", "ID Profile") : body
+        return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile offline_access")] -- TODO read from config
+      else return $ ("scope", "openid profile offline_access") : body -- TODO read from config
     $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
     eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
     case eResult of
@@ -142,3 +147,4 @@ refreshOAuth2Token (_, rToken) url secure
 instance Show RequestBody where
   show (RequestBodyLBS x) = show x
   show _ = error ":("
+
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index 49b6b5de9..ca9dc9ad3 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -11,11 +11,14 @@ module Foundation.Instances
   , unsafeHandler
   ) where
 
+import qualified Prelude as P
+
 import Import.NoFoundation
 
 import qualified Data.Text as Text
 import Data.List (inits)
 
+import Yesod.Auth.OAuth2
 import qualified Yesod.Core.Unsafe as Unsafe
 import qualified Yesod.Auth.Message as Auth
 
@@ -23,6 +26,7 @@ import Utils.Form
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
+import Auth.OAuth2
 
 import qualified Foundation.Yesod.Session as UniWorX
 import qualified Foundation.Yesod.Middleware as UniWorX
@@ -133,17 +137,20 @@ instance YesodAuth UniWorX where
     redirectToReferer _ = True
 
     loginHandler = do
+      plugins <- getsYesod authPlugins
+      AppSettings{..} <- getsYesod appSettings'
+
+      when appSingleSignOn $ do
+        let plugin = P.head $ P.filter ((`elem` [mockPluginName, azurePluginName]) . apName) plugins
+            pieces = case oauth2Url (apName plugin) of
+                      PluginR _ p -> p
+                      _ -> error "Unexpected OAuth2 AuthRoute"
+        void $ apDispatch plugin "GET" pieces
+
       toParent <- getRouteToParent
       liftHandler . defaultLayout $ do
-        plugins <- getsYesod authPlugins
         $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
-
-#ifdef DEVELOPMENT
         mPort <- liftIO $ lookupEnv "OAUTH2_SERVER_PORT"
-#else
-        let mPort = Nothing
-#endif
-
         setTitleI MsgLoginTitle
         $(widgetFile "login")
 
diff --git a/src/Settings.hs b/src/Settings.hs
index e3fcc6105..5dadb7646 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,David Mosbach 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -96,6 +96,8 @@ data AppSettings = AppSettings
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
+    , appSingleSignOn           :: Bool
+    -- ^ Enable OIDC single sign-on
     , appLdapConf               :: Maybe (PointedList LdapConf)
     -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
     , appLmsConf                :: LmsConf
@@ -627,6 +629,7 @@ instance FromJSON AppSettings where
         appWebpackEntrypoints     <- o .: "webpack-manifest"
         appDatabaseConf           <- o .: "database"
         appAutoDbMigrate          <- o .: "auto-db-migrate"
+        appSingleSignOn           <- o .: "single-sign-on"
         let nonEmptyHost LdapConf{..} = case ldapHost of
               Ldap.Tls host _ -> not $ null host
               Ldap.Plain host -> not $ null host

From d88acf46345657da6d5b01aa76d9fa8106294ee0 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Wed, 6 Mar 2024 04:26:47 +0000
Subject: [PATCH 125/178] chore(auth): updated mock server

---
 shell.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/shell.nix b/shell.nix
index 7b3fd32e9..48d9cc57e 100644
--- a/shell.nix
+++ b/shell.nix
@@ -9,7 +9,7 @@ let
 
   haskellPackages = pkgs.haskellPackages;
 
-  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=45debf40cd171f78a4de38f608a6cfd3be73b91a&ref=oidc").packages.x86_64-linux;
+  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=83d99e55303f5b1cd6cde30b2936d61419268f8c&ref=oidc").packages.x86_64-linux;
 
 
   oauth2MockServer = oauth2Flake.default;

From b947037ea29bb721f3c5cade28ba606ad3e9e26f Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Thu, 7 Mar 2024 03:31:17 +0000
Subject: [PATCH 126/178] feat(auth): implemented single sign out

---
 .../categories/authorization/de-de-formal.msg |  4 +++-
 .../categories/authorization/en-eu.msg        |  4 +++-
 routes                                        |  4 +++-
 src/Application.hs                            |  1 +
 src/Auth/OAuth2.hs                            | 23 ++++++++++++++++++-
 src/Foundation/Instances.hs                   |  5 ++++
 src/Foundation/Navigation.hs                  |  3 ++-
 src/Handler/SingleSignOut.hs                  | 23 +++++++++++++++++++
 8 files changed, 62 insertions(+), 5 deletions(-)
 create mode 100644 src/Handler/SingleSignOut.hs

diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg
index f9a26de23..4c0773001 100644
--- a/messages/uniworx/categories/authorization/de-de-formal.msg
+++ b/messages/uniworx/categories/authorization/de-de-formal.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,David Mosbach 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -139,3 +139,5 @@ FormHoneypotNamePlaceholder: Name
 FormHoneypotComment: Kommentar
 FormHoneypotCommentPlaceholder: Kommentar
 FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus
+
+SingleSignOut: Abmeldung bei Azure
diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg
index b539efbf1..7dc17b924 100644
--- a/messages/uniworx/categories/authorization/en-eu.msg
+++ b/messages/uniworx/categories/authorization/en-eu.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,David Mosbach 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -140,3 +140,5 @@ FormHoneypotNamePlaceholder !ident-ok: Name
 FormHoneypotComment: Comment
 FormHoneypotCommentPlaceholder: Comment
 FormHoneypotFilled: Please do not fill in any of the hidden fields
+
+SingleSignOut: Azure logout
diff --git a/routes b/routes
index 2376c33af..e42a707e5 100644
--- a/routes
+++ b/routes
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -46,6 +46,8 @@
 /static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free
 
+/ssout SSOutR  GET !free -- single sign-out (OIDC)
+
 /metrics     MetricsR GET																			!free -- verify if this can be free
 
 /err                          ErrorR           GET            !free
diff --git a/src/Application.hs b/src/Application.hs
index 08fef42ee..215f4631d 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -164,6 +164,7 @@ import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
 import Handler.Firm
+import Handler.SingleSignOut
 
 import ServantApi () -- YesodSubDispatch instances
 import Servant.API
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 613a1ddd5..c85af461b 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -11,12 +11,13 @@ module Auth.OAuth2
 , mockPluginName
 , queryOAuth2User
 , UserDataException
+, singleSignOut
 ) where
 
 import Data.Maybe (fromJust)
 import Data.Text
 
-import Import.NoFoundation hiding (unpack)
+import Import.NoFoundation hiding (pack, unpack)
 
 import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException)
 
@@ -148,3 +149,23 @@ instance Show RequestBody where
   show (RequestBodyLBS x) = show x
   show _ = error ":("
 
+
+ -----------------------
+---- Single Sign-Out ----
+ -----------------------
+ 
+singleSignOut :: forall a m. (MonadHandler m)
+              => Maybe Text -- ^ redirect uri
+              -> m a
+singleSignOut mRedirect = do
+# ifdef DEVELOPMENT
+  port <- liftIO $ fromJust <$> lookupEnv "OAUTH2_SERVER_PORT"
+  let base = "http://localhost:" <> pack port <> "/logout"
+# else
+  let base = "" -- TODO find out fraport oidc end_session_endpoint
+# endif
+      endpoint = case mRedirect of
+        Just r -> base <> "?post_logout_redirect_uri=" <> r
+        Nothing -> base
+  redirect endpoint
+
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index ca9dc9ad3..e4d81cf88 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -174,6 +174,11 @@ instance YesodAuth UniWorX where
       
       addMessage Success . toHtml $ mr Auth.NowLoggedIn
 
+    -- onLogout = do
+    --   AppSettings{..} <- getsYesod appSettings'
+    --   when appSingleSignOn $ singleSignOut @UniWorX Nothing
+        
+
     onErrorHtml dest msg = do
       addMessage Error $ toHtml msg
       redirect dest
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index bf486ed22..c0a642a2e 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -73,6 +73,7 @@ breadcrumb :: ( BearerAuthSite UniWorX
            => Route UniWorX
            -> m Breadcrumb
 breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just NewsR
+breadcrumb SSOutR           = i18nCrumb MsgSingleSignOut       Nothing
 breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
 breadcrumb (WellKnownR _)   = i18nCrumb MsgBreadcrumbWellKnown Nothing
 breadcrumb MetricsR         = i18nCrumb MsgBreadcrumbMetrics   Nothing
@@ -546,7 +547,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       , navIcon       = IconMenuLogout
       , navLink       = NavLink
         { navLabel       = MsgMenuLogout
-        , navRoute       = AuthR LogoutR
+        , navRoute       = SSOutR -- AuthR LogoutR
         , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
         , navType        = NavTypeLink { navModal = False }
         , navQuick'      = mempty
diff --git a/src/Handler/SingleSignOut.hs b/src/Handler/SingleSignOut.hs
new file mode 100644
index 000000000..44ec813a2
--- /dev/null
+++ b/src/Handler/SingleSignOut.hs
@@ -0,0 +1,23 @@
+-- SPDX-FileCopyrightText: 2024 David Mosbach 
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.SingleSignOut
+  ( getSSOutR
+  ) where
+
+import Import
+import Auth.OAuth2 (singleSignOut)
+import qualified Network.Wai as W
+
+
+getSSOutR :: Handler Html
+getSSOutR = do
+  app <- getYesod
+  let logoutR = intercalate "/" . fst . renderRoute $ AuthR LogoutR
+      root = case approot of
+        ApprootRequest f -> f app W.defaultRequest
+        _ -> error "approt implementation changed"
+  AppSettings{..} <- getsYesod appSettings'
+  if appSingleSignOn then singleSignOut (Just $ root <> "/" <> logoutR) else redirect (AuthR LogoutR)
+

From 77a9100b2ebbc79a7ff13b070aa2c5535f7c6dfd Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 7 Mar 2024 05:36:03 +0100
Subject: [PATCH 127/178] chore(auth): refactor; add util function

---
 src/Model/Types/Auth.hs | 2 +-
 src/Settings.hs         | 5 +++++
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs
index add176291..c1704c7bc 100644
--- a/src/Model/Types/Auth.hs
+++ b/src/Model/Types/Auth.hs
@@ -75,7 +75,7 @@ type UserEduPersonPrincipalName = Text
 -- | Used for uniquely storing ExternalUser entries per user and source
 data AuthSourceIdent
   = AuthSourceIdAzure
-    { authSourceIdAzureClientId :: UUID
+    { authSourceIdAzureClientId :: UUID -- FIXME: use tenant id instead
     }
   | AuthSourceIdLdap
     { authSourceIdLdapHost :: Text -- normally either just the hostname, or hostname and port
diff --git a/src/Settings.hs b/src/Settings.hs
index 9aa46f6b1..238d21791 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -155,6 +155,11 @@ data UserAuthConf =
   -- | UserAuthConfNoSource -- ^ allow no external sources at all -- TODO: either this, or make user-auth in settings.yml optional
   deriving (Show)
 
+mkAuthSourceIdent :: AuthSourceConf -> AuthSourceIdent
+mkAuthSourceIdent = \case
+  AuthSourceConfAzureAdV2 AzureConf{..} -> AuthSourceIdAzure azureConfClientId
+  AuthSourceConfLdap      LdapConf{..}  -> AuthSourceIdLdap  ldapConfSourceId
+
 data LmsConf = LmsConf
   { lmsUploadHeader       :: Bool
   , lmsUploadDelimiter    :: Maybe Char

From 4feb05a02e5887d4dc75c35d0ba3044923b32aed Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 7 Mar 2024 05:37:27 +0100
Subject: [PATCH 128/178] chore(foundation): tweak UpsertUserData fields

---
 src/Foundation/Types.hs | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs
index 0cb2f2234..f76076f33 100644
--- a/src/Foundation/Types.hs
+++ b/src/Foundation/Types.hs
@@ -8,7 +8,7 @@ module Foundation.Types
   , _upsertUserSource, _upsertUserIdent
   , UpsertUserData(..)
   , _UpsertUserDataAzure, _UpsertUserDataLdap
-  , _upsertUserAzureConf, _upsertUserAzureData, _upsertUserLdapConf, _upsertUserLdapData
+  , _upsertUserAzureTenantId, _upsertUserAzureData, _upsertUserLdapHost, _upsertUserLdapData
   ) where
 
 import Import.NoFoundation
@@ -16,6 +16,7 @@ import Import.NoFoundation
 import qualified Ldap.Client as Ldap
 
 
+-- TODO: rename?
 data UpsertUserMode
   = UpsertUserLogin      { upsertUserSource :: Text } -- TODO: use type synonym?
   | UpsertUserLoginDummy { upsertUserIdent  :: UserIdent }
@@ -30,12 +31,12 @@ makePrisms ''UpsertUserMode
 
 data UpsertUserData
   = UpsertUserDataAzure
-    { upsertUserAzureConf :: AzureConf
-    , upsertUserAzureData :: [(Text, [ByteString])]  -- TODO: use type synonym?
+    { upsertUserAzureTenantId :: UUID
+    , upsertUserAzureData     :: [(Text, [ByteString])]  -- TODO: use type synonym?
     }
   | UpsertUserDataLdap
-    { upsertUserLdapConf  :: LdapConf
-    , upsertUserLdapData  :: Ldap.AttrList []
+    { upsertUserLdapHost      :: Text
+    , upsertUserLdapData      :: Ldap.AttrList []
     }
   deriving (Show)
 

From aca5a79de26ac4ae552b9359a60fd9f081013bb0 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 7 Mar 2024 05:38:39 +0100
Subject: [PATCH 129/178] chore(auth): implement fetchUserData, generalized
 version of azureUser and ldapUser

---
 src/Auth/LDAP.hs             |   2 +
 src/Auth/OAuth2.hs           |  68 +++++++----
 src/Foundation/Yesod/Auth.hs | 223 +++++++++++++++++++++--------------
 3 files changed, 182 insertions(+), 111 deletions(-)

diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index f14e60683..036d40b17 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -116,6 +116,7 @@ ldapUserEmail = Ldap.Attr "mail" :|
   ]
 
 
+-- TODO: deprecate in favour of FetchUserDataException
 data LdapUserException = LdapUserLdapError LdapPoolError
                        | LdapUserNoResult
                        | LdapUserAmbiguous
@@ -182,6 +183,7 @@ ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . Ld
 --   where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey 
 
 
+-- TODO: deprecate in favour of fetchUserData
 ldapUser :: ( MonadMask m
             , MonadUnliftIO m
           --, MonadLogger m
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 6d3847104..8d217cbf3 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -7,7 +7,7 @@
 module Auth.OAuth2
   ( apAzure
   , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage
-  , azureUser, azureUser'
+  -- , azureUser, azureUser'
   , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous
   , apAzureMock
   , azureMockServer
@@ -15,7 +15,7 @@ module Auth.OAuth2
   , refreshOAuth2Token
   ) where
 
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 import Data.Maybe (fromJust)
 import Data.Text
 
@@ -33,6 +33,7 @@ apAzure :: Text
 apAzure = "AzureADv2"
 
 
+-- TODO: deprecate in favour of FetchUserDataException
 data AzureUserException = AzureUserError
                         | AzureUserNoResult
                         | AzureUserAmbiguous
@@ -56,28 +57,49 @@ azureUserPreferredLanguage = "preferredLanguage"
 
 
 -- | User lookup in Microsoft Graph with given credentials
-azureUser :: ( MonadMask m
-             , MonadHandler m
-             )
-             => AzureConf
-             -> Creds site
-             -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])])
-azureUser _conf Creds{..} = fmap throwLeft . runExceptT $ do
-  results <- queryOAuth2User @[(Text, [ByteString])] credsIdent
-  case results of
-    Left _ -> throwE AzureUserNoResult
-    Right [res] -> return res
-    Right _multiple -> throwE AzureUserAmbiguous
+-- TODO: deprecate in favour of fetchUserData
+-- azureUser :: ( MonadMask m
+--              , MonadHandler m
+--              -- , HandlerSite m ~ site
+--              -- , BackendCompatible SqlBackend (YesodPersistBackend site)
+--              -- , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+--              -- , YesodPersist site
+--              -- , PersistUniqueWrite (YesodPersistBackend site)
+--              )
+--              => AzureConf
+--              -> Creds site
+--              -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])])
+-- azureUser AzureConf{..} Creds{..} = fmap throwLeft . runExceptT $ do
+--   now <- liftIO getCurrentTime
+--   results <- queryOAuth2User @[(Text, [ByteString])] credsIdent
+--   case results of
+--     Right [res] -> do
+--       -- void . liftHandler . runDB $ upsert ExternalUser
+--       --   { externalUserUser     =  error "no userid" -- TODO: use azureUserPrimaryKey once UserIdent is referenced instead of UserId
+--       --   , externalUserSource   =  AuthSourceIdAzure azureConfClientId
+--       --   , externalUserData     =  toJSON res
+--       --   , externalUserLastSync =  now
+--       --   }
+--       --   [ ExternalUserData     =. toJSON res
+--       --   , ExternalUserLastSync =. now
+--       --   ]
+--       return res
+--     Right _multiple -> throwE AzureUserAmbiguous
+--     Left _ -> throwE AzureUserNoResult
 
 -- | User lookup in Microsoft Graph with given user
-azureUser' :: ( MonadMask m
-              , MonadHandler m
-             )
-             => AzureConf
-             -> User
-             -> m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])])
-azureUser' conf User{userIdent}
-  = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) [])
+-- azureUser' :: ( MonadMask m
+--               , MonadHandler m
+--               , HandlerSite m ~ site
+--               , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+--               , YesodPersist site
+--               , PersistUniqueWrite (YesodPersistBackend site)
+--               )
+--              => AzureConf
+--              -> User
+--              -> ReaderT (YesodPersistBackend site) m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])])
+-- azureUser' conf User{userIdent}
+--   = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) [])
 
 
 ----------------------------------------
@@ -183,7 +205,7 @@ refreshOAuth2Token (_, rToken) url secure
         clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID"
         clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET"
         return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")]
-      else return $ ("scope", "ID Profile") : body
+      else return $ scopeParam " " ["ID","Profile"] : body
     $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
     eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
     case eResult of
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 69a967e00..bb65f2115 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -4,7 +4,7 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , ldapLookupAndUpsert -- TODO generalize
+  -- , ldapLookupAndUpsert -- TODO: remove in favour of fetchUserData
   , upsertUser
   , decodeUserTest
   , UserConversionException(..)
@@ -35,6 +35,7 @@ import qualified Control.Monad.Catch as C (Handler(..))
 import qualified Data.ByteString as ByteString
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Map as Map
+import qualified Data.List.NonEmpty as NonEmpty (toList)
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -55,7 +56,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
   $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
 
   now <- liftIO getCurrentTime
-  userAuthConf <- getsYesod $ view _appUserAuthConf
+  userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only
   $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only
 
   let
@@ -77,27 +78,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       = return res
 
     excHandlers =
-      -- TODO: merge ldap and azure exception types
-      [ C.Handler $ \(ldapExc :: LdapUserException) -> case ldapExc of
-          LdapUserNoResult -> do
-            $logWarnS "Auth" $ "LDAP user lookup failed after successful login for " <> credsIdent
+      [ C.Handler $ \(fExc :: FetchUserDataException) -> case fExc of
+          FetchUserDataNoResult -> do
+            $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
-          LdapUserAmbiguous -> do
-            $logWarnS "Auth" $ "Multiple LDAP auth results for " <> credsIdent
+          FetchUserDataAmbiguous -> do
+            $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           err -> do
-            $logErrorS "Auth" $ tshow err
-            mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLoginError
-      , C.Handler $ \case
-          AzureUserNoResult -> do
-            $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent
-            excRecovery . UserError $ IdentifierNotFound credsIdent
-          AzureUserAmbiguous -> do
-            $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent
-            excRecovery . UserError $ IdentifierNotFound credsIdent
-          err -> do
-            $logErrorS "OAuth" $ tshow err
+            $logErrorS "FetchUserException" $ tshow err
             mr <- getMessageRender
             excRecovery . ServerError $ mr MsgInternalLoginError
       , C.Handler $ \(cExc :: UserConversionException) -> do
@@ -123,22 +112,27 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
   flip catches excHandlers $ if
     | not isDummy, not isOther
-    , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
+    -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
     , Just upsertMode' <- upsertMode -> do
-        upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
-        $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
-        Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
-    | not isDummy, not isOther
-    , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
-    , Just upsertMode' <- upsertMode -> do
-        ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-        upsertUserLdapData <- ldapUser ldapPool Creds{..}
-        $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
-        Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
+        userData <- fetchUserData upsertMode' Creds{..}
+        $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
+        Authenticated . entityKey <$> upsertUser upsertMode' userData
+        -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
+        -- upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
+        -- $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
+        -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
+    -- | not isDummy, not isOther
+    -- , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
+    -- , Just upsertMode' <- upsertMode -> do
+    --     ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
+    --     upsertUserLdapData <- ldapUser ldapPool Creds{..}
+    --     $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
+    --     Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
     | otherwise
       -> acceptExisting
 
 
+-- TODO: rename to DecodeUserException (associate with function!)
 data UserConversionException
   = UserInvalidIdent
   | UserInvalidEmail
@@ -175,33 +169,75 @@ _upsertUserMode mMode cs@Creds{..}
     defaultOther = apHash
 
 
--- TODO: generalize
-ldapLookupAndUpsert :: forall m.
-                       ( MonadHandler m
-                       , HandlerSite m ~ UniWorX
-                       , MonadMask m
-                       , MonadUnliftIO m
-                       )
-                    => Text
-                    -> SqlPersistT m (Entity User)
-ldapLookupAndUpsert ident = 
-  getsYesod (view _appLdapPool) >>= \case 
-    Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
-    Just ldapPool@(upsertUserLdapConf, _) ->
-      ldapUser'' ldapPool ident >>= \case
-        Nothing -> throwM LdapUserNoResult
-        Just upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}
+data FetchUserDataException
+  = FetchUserDataNoResult
+  | FetchUserDataAmbiguous
+  | FetchUserDataException
+  deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (Exception)
+
+-- TODO: deprecate in favour of fetchUserData
+-- ldapLookupAndUpsert :: forall m.
+--                        ( MonadHandler m
+--                        , HandlerSite m ~ UniWorX
+--                        , MonadMask m
+--                        , MonadUnliftIO m
+--                        )
+--                     => Text
+--                     -> SqlPersistT m (Entity User)
+-- ldapLookupAndUpsert ident = 
+--   getsYesod (view _appLdapPool) >>= \case 
+--     Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
+--     Just ldapPool ->
+--       ldapUser'' ldapPool ident >>= \case
+--         Nothing -> throwM LdapUserNoResult
+--         Just ldapData -> upsertUser UpsertUserGuessUser ldapData
+
+
+-- | Fetch user data with given credentials from external source(s)
+fetchUserData :: forall m site.
+                 ( MonadHandler m
+                 , HandlerSite m ~ UniWorX
+                 , MonadCatch m
+                 )
+              => UpsertUserMode
+              -> Creds site
+              -> SqlPersistT m (NonEmpty UpsertUserData)
+fetchUserData upsertMode creds@Creds{..} = do
+  userAuthConf <- getsYesod $ view _appUserAuthConf
+  now <- liftIO getCurrentTime
+
+  results :: NonEmpty UpsertUserData <- case userAuthConf of
+    UserAuthConfSingleSource{..} -> fmap throwLeft . runExceptT $ case userAuthConfSingleSource of
+      AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
+        queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
+          Right upsertUserAzureData -> return UpsertUserDataAzure{..}
+          Left _ -> throwE FetchUserDataNoResult
+      AuthSourceConfLdap LdapConf{..} -> do
+        ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool
+        UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds
+
+  -- insert ExternalUser entries for each fetched dataset
+  forM_ results $ \res ->
+    let externalUserUser =  error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId
+        externalUserLastSync = now
+        (externalUserData, externalUserSource) = case res of
+          UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
+          UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
+     in void . liftHandler . runDB $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
+
+  return results
 
 
 -- | Upsert User and related auth in DB according to given external source data (does not query source itself)
 upsertUser :: forall m.
-                  ( MonadHandler m
-                  , HandlerSite m ~ UniWorX
-                  , MonadCatch m
-                  )
-               => UpsertUserMode
-               -> UpsertUserData
-               -> SqlPersistT m (Entity User)
+              ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              , MonadCatch m
+              )
+           => UpsertUserMode
+           -> NonEmpty UpsertUserData
+           -> SqlPersistT m (Entity User)
 upsertUser _upsertMode upsertData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
@@ -234,7 +270,7 @@ upsertUser _upsertMode upsertData = do
 
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-    userSystemFunctions' = case upsertData of
+    userSystemFunctions' = concat $ upsertData <&> \case
       UpsertUserDataAzure{..} -> do
         (_k, v) <- upsertUserAzureData
         v' <- v
@@ -259,7 +295,7 @@ decodeUser :: ( MonadThrow m
               )
            => UTCTime -- ^ Now
            -> UserDefaultConf
-           -> UpsertUserData -- ^ Raw source data
+           -> NonEmpty UpsertUserData -- ^ Raw source data
            -> m (User,_) -- ^ Data for new User entry and updating existing User entries
 decodeUser now UserDefaultConf{..} upsertData = do
     userIdent <- if
@@ -275,35 +311,47 @@ decodeUser now UserDefaultConf{..} upsertData = do
         -> throwM UserInvalidIdent
 
     let
-      (userSurname, userFirstName, userDisplayName, userEmail, userTelephone, userMobile, userCompanyPersonalNumber, userCompanyDepartment, userLanguages)
+      (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
         | Just azureData <- mbAzureData
-          = ( azureData `decodeAzure'` azureUserSurname
-            , azureData `decodeAzure'` azureUserGivenName
-            , azureData `decodeAzure'` azureUserDisplayName
-            , CI.mk $
-              azureData `decodeAzure'` azureUserMail
-            , azureData `decodeAzure`  azureUserTelephone
-            , azureData `decodeAzure`  azureUserMobile
-            , Nothing -- userCompanyPersonalNumber not contained in Azure response
-            , Nothing -- userCompanyDepartment not contained in Azure response
-            , Nothing -- azureData `decodeAzure`  azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
-            )
-        | Just ldapData <- mbLdapData
-          = ( ldapData `decodeLdap'` ldapUserSurname
-            , ldapData `decodeLdap'` ldapUserFirstName
-            , ldapData `decodeLdap'` ldapUserDisplayName
-            , CI.mk $
-              ldapData `decodeLdap'` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
-            , ldapData `decodeLdap`  ldapUserTelephone
-            , ldapData `decodeLdap`  ldapUserMobile
-            , ldapData `decodeLdap`  ldapUserFraportPersonalnummer
-            , ldapData `decodeLdap`  ldapUserFraportAbteilung
-            , Nothing -- userLanguage not contained in LDAP response
+          = ( azureData `decodeAzure` azureUserSurname
+            , azureData `decodeAzure` azureUserGivenName
+            , azureData `decodeAzure` azureUserDisplayName
+            , azureData `decodeAzure` azureUserMail
+            , azureData `decodeAzure` azureUserTelephone
+            , azureData `decodeAzure` azureUserMobile
+            , Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
             )
         | otherwise
-          = error "decodeUser: Both azureData and ldapData are empty, cannot decode basic fields from no data!"
+          = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
 
+      (ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment)
+        | Just ldapData <- mbLdapData
+          = ( ldapData `decodeLdap` ldapUserSurname
+            , ldapData `decodeLdap` ldapUserFirstName
+            , ldapData `decodeLdap` ldapUserDisplayName
+            , ldapData `decodeLdap` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
+            , ldapData `decodeLdap` ldapUserTelephone
+            , ldapData `decodeLdap` ldapUserMobile
+            , ldapData `decodeLdap` ldapUserFraportPersonalnummer
+            , ldapData `decodeLdap` ldapUserFraportAbteilung
+            )
+        | otherwise
+          = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
+
+    -- TODO: throw on collisions?
+
+    -- TODO: use user-auth precedence from app config when implementing multi-source support
     let
+      userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname
+      userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName
+      userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName
+      userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail
+      userTelephone = azureTelephone <|> ldapTelephone
+      userMobile = azureMobile <|> ldapMobile
+      userLanguages = azureLanguages
+      userCompanyPersonalNumber = ldapCompanyPersonalNumber
+      userCompanyDepartment = ldapCompanyDepartment
+
       newUser = User
         { userMaxFavourites         =  userDefaultMaxFavourites
         , userMaxFavouriteTerms     =  userDefaultMaxFavouriteTerms
@@ -349,10 +397,9 @@ decodeUser now UserDefaultConf{..} upsertData = do
 
   where
     mbAzureData :: Maybe (Map Text [ByteString])
-    mbAzureData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserAzureData upsertData
+    mbAzureData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
     mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
-    mbLdapData = Map.fromListWith (++) . fmap (second . filter $ not . ByteString.null) <$> preview _upsertUserLdapData upsertData
-    -- ldapData = fmap (Map.fromListWith (++)) $ upsertData ^? _upsertUserLdapData . over _2 (filter $ not . ByteString.null)
+    mbLdapData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
 
     -- just returns Nothing on error, pure
     decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
@@ -360,10 +407,10 @@ decodeUser now UserDefaultConf{..} upsertData = do
     decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
     decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
 
-    decodeAzure' :: Map Text [ByteString] -> Text -> Text
-    decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
-    decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
-    decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
+    -- decodeAzure' :: Map Text [ByteString] -> Text -> Text
+    -- decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
+    -- decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
+    -- decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
     -- accept the first successful decoding or empty; only throw an error if all decodings fail
     -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
     -- decodeLdap' attr err
@@ -393,7 +440,7 @@ decodeUserTest :: ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , MonadCatch m
                   )
-               => UpsertUserData
+               => NonEmpty UpsertUserData
                -> m (Either UserConversionException (User, [Update User]))
 decodeUserTest decodeData = do
   now <- liftIO getCurrentTime

From d71ff014ea981c38e62af3e685e85e454fd8c8c3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 7 Mar 2024 15:30:48 +0100
Subject: [PATCH 130/178] chore(ldap): derive more json instances

---
 src/Ldap/Client/Instances.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs
index 080c84f75..9f2580333 100644
--- a/src/Ldap/Client/Instances.hs
+++ b/src/Ldap/Client/Instances.hs
@@ -53,4 +53,5 @@ derivePersistField "Dn"
 derivePersistField "Password"
 derivePersistField "Scope"
 
-deriveFromJSON defaultOptions ''Scope
+deriveJSON defaultOptions ''Attr
+deriveJSON defaultOptions ''Scope

From 95803db3a0460126e56e56b6d13e08fb6967d4e7 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 7 Mar 2024 15:32:07 +0100
Subject: [PATCH 131/178] chore(auth): fix fetchUserData

---
 src/Foundation/Yesod/Auth.hs | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index bb65f2115..3d32db6f7 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -199,20 +199,22 @@ fetchUserData :: forall m site.
                  ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  , MonadCatch m
+                 , MonadMask m
+                 , MonadUnliftIO m
                  )
               => UpsertUserMode
               -> Creds site
               -> SqlPersistT m (NonEmpty UpsertUserData)
-fetchUserData upsertMode creds@Creds{..} = do
+fetchUserData _upsertMode creds@Creds{..} = do
   userAuthConf <- getsYesod $ view _appUserAuthConf
   now <- liftIO getCurrentTime
 
   results :: NonEmpty UpsertUserData <- case userAuthConf of
-    UserAuthConfSingleSource{..} -> fmap throwLeft . runExceptT $ case userAuthConfSingleSource of
+    UserAuthConfSingleSource{..} -> (:| []) <$> case userAuthConfSingleSource of
       AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
         queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
           Right upsertUserAzureData -> return UpsertUserDataAzure{..}
-          Left _ -> throwE FetchUserDataNoResult
+          Left _ -> throwM FetchUserDataNoResult
       AuthSourceConfLdap LdapConf{..} -> do
         ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool
         UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds
@@ -224,7 +226,7 @@ fetchUserData upsertMode creds@Creds{..} = do
         (externalUserData, externalUserSource) = case res of
           UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
           UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
-     in void . liftHandler . runDB $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
+     in void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
 
   return results
 

From 78a8442d072237ad167837abe86055c4d22ec72b Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 7 Mar 2024 23:24:41 +0100
Subject: [PATCH 132/178] chore(auth): userLookupAndUpsert

---
 src/Foundation/Yesod/Auth.hs | 40 +++++++++++++++---------------------
 1 file changed, 17 insertions(+), 23 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 3d32db6f7..2dec06d63 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -4,7 +4,7 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  -- , ldapLookupAndUpsert -- TODO: remove in favour of fetchUserData
+  , userLookupAndUpsert
   , upsertUser
   , decodeUserTest
   , UserConversionException(..)
@@ -114,7 +114,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
     | not isDummy, not isOther
     -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
     , Just upsertMode' <- upsertMode -> do
-        userData <- fetchUserData upsertMode' Creds{..}
+        userData <- fetchUserData Creds{..}
         $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
         Authenticated . entityKey <$> upsertUser upsertMode' userData
         -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
@@ -169,6 +169,19 @@ _upsertUserMode mMode cs@Creds{..}
     defaultOther = apHash
 
 
+userLookupAndUpsert :: forall m.
+                       ( MonadHandler m
+                       , HandlerSite m ~ UniWorX
+                       , MonadMask m
+                       , MonadUnliftIO m
+                       )
+                    => Text
+                    -> UpsertUserMode
+                    -> SqlPersistT m (Entity User)
+userLookupAndUpsert credsIdent mode =
+  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= upsertUser mode
+
+
 data FetchUserDataException
   = FetchUserDataNoResult
   | FetchUserDataAmbiguous
@@ -176,24 +189,6 @@ data FetchUserDataException
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Exception)
 
--- TODO: deprecate in favour of fetchUserData
--- ldapLookupAndUpsert :: forall m.
---                        ( MonadHandler m
---                        , HandlerSite m ~ UniWorX
---                        , MonadMask m
---                        , MonadUnliftIO m
---                        )
---                     => Text
---                     -> SqlPersistT m (Entity User)
--- ldapLookupAndUpsert ident = 
---   getsYesod (view _appLdapPool) >>= \case 
---     Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
---     Just ldapPool ->
---       ldapUser'' ldapPool ident >>= \case
---         Nothing -> throwM LdapUserNoResult
---         Just ldapData -> upsertUser UpsertUserGuessUser ldapData
-
-
 -- | Fetch user data with given credentials from external source(s)
 fetchUserData :: forall m site.
                  ( MonadHandler m
@@ -202,10 +197,9 @@ fetchUserData :: forall m site.
                  , MonadMask m
                  , MonadUnliftIO m
                  )
-              => UpsertUserMode
-              -> Creds site
+              => Creds site
               -> SqlPersistT m (NonEmpty UpsertUserData)
-fetchUserData _upsertMode creds@Creds{..} = do
+fetchUserData creds@Creds{..} = do
   userAuthConf <- getsYesod $ view _appUserAuthConf
   now <- liftIO getCurrentTime
 

From 8c4ec00c35e3acbf0df287f9397d1a14a626f2dc Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 09:54:30 +0100
Subject: [PATCH 133/178] chore(ldap): ldapSearch for arbitrary number of
 results

---
 src/Auth/LDAP.hs | 12 ++++++++++++
 1 file changed, 12 insertions(+)

diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 036d40b17..a5a2d2813 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -20,6 +20,7 @@ module Auth.LDAP
   , ldapUserMobile, ldapUserTelephone
   , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
   , ldapUserTitle
+  , ldapSearch
   ) where
 
 import Import.NoFoundation
@@ -96,6 +97,17 @@ userSearchSettings LdapConf{..} = mconcat
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
+ldapSearch :: forall m.
+              ( MonadUnliftIO m
+              , MonadCatch m
+              )
+           => (LdapConf, LdapPool)
+           -> Text -- ^ needle
+           -> m [Ldap.SearchEntry]
+ldapSearch (conf@LdapConf{..}, ldapPool) needle = either (throwM . LdapUserLdapError) return <=< withLdap ldapPool $ \ldap -> liftIO $ do
+  Ldap.bind ldap ldapConfDn ldapConfPassword
+  findUser conf ldap needle []
+
 ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone,  ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung  :: Ldap.Attr
 ldapPrimaryKey            = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"

From 2480efc345a2bde7a80f45b494aaa01a59eb8dfa Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 09:55:51 +0100
Subject: [PATCH 134/178] chore: userLookupAndUpsert contd

---
 src/Handler/Utils/Avs.hs   | 13 ++++++-------
 src/Handler/Utils/Users.hs |  4 ++--
 2 files changed, 8 insertions(+), 9 deletions(-)

diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 790479aff..3743dcd8f 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -35,8 +35,7 @@ import qualified Data.Set             as Set
 import qualified Data.Map             as Map
 import qualified Data.Text            as Text
 import qualified Data.CaseInsensitive as CI
--- import Auth.LDAP (ldapUserPrincipalName)
-import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
+import Foundation.Yesod.Auth (userLookupAndUpsert)
 
 import Handler.Utils.Company
 import Handler.Utils.Qualification
@@ -355,12 +354,12 @@ guessAvsUser someid = do
             [Entity uid _] -> return $ Just uid
             _              -> return Nothing
         uid -> return uid
-    Nothing -> try (runDB $ ldapLookupAndUpsert someid) >>= \case
+    Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case
       Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> 
         maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo))
       Right Entity{entityKey=uid} -> return $ Just uid
       other -> do -- attempt to recover by trying other ids
-        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
+        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all      
         runDB . runMaybeT $ 
           let someIdent = stripCI someid
           in    MaybeT (getKeyBy $ UniqueEmail          someIdent)
@@ -370,7 +369,7 @@ guessAvsUser someid = do
 upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
 upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid    -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
 upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
-  try (runDB $ ldapLookupAndUpsert otherId) >>= \case
+  try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case
     Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
     other -> do -- attempt to recover by trying other ids
       whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
@@ -421,7 +420,7 @@ upsertAvsUserById api = do
               (_:_) -> throwM $ AvsUserAmbiguous api
               [] -> do
                 upsRes :: Either SomeException (Entity User)
-                  <- try $ ldapLookupAndUpsert persNo -- TODO: do azure lookup and upsert if appropriate
+                  <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate
                 $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
                 case upsRes of
                   Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 24b395ca1..2580d1700 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -237,9 +237,9 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
           -- TODO: Generalize
           doLdap userMatr = do
             ldapPool' <- getsYesod $ view _appLdapPool
-            fmap join . for ldapPool' $ \ldapPool@(upsertUserLdapConf,_) -> do
+            fmap join . for ldapPool' $ \ldapPool@(LdapConf{ ldapConfSourceId = upsertUserLdapHost },_) -> do
               ldapData <- ldapUserMatr' ldapPool userMatr
-              for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}
+              for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser $ UpsertUserDataLdap{..} :| []
 
       let
         getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation

From 969cc4df63bf552ce152dc0c012a31ef07fceb44 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 09:56:27 +0100
Subject: [PATCH 135/178] chore(jobs): use userLookupAndUpsert for synchronise
 user job

---
 src/Jobs/Handler/SynchroniseUser.hs | 35 ++++++-----------------------
 1 file changed, 7 insertions(+), 28 deletions(-)

diff --git a/src/Jobs/Handler/SynchroniseUser.hs b/src/Jobs/Handler/SynchroniseUser.hs
index 883dc8ca6..231dd851d 100644
--- a/src/Jobs/Handler/SynchroniseUser.hs
+++ b/src/Jobs/Handler/SynchroniseUser.hs
@@ -9,11 +9,10 @@ module Jobs.Handler.SynchroniseUser
 
 import Import
 
-import qualified Data.Conduit.List as C
+import Foundation.Yesod.Auth (userLookupAndUpsert)
 
-import Auth.LDAP
-import Auth.OAuth2
-import Foundation.Yesod.Auth (UserConversionException, upsertUser)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Conduit.List as C
 
 import Jobs.Queue
 
@@ -43,27 +42,7 @@ dispatchJobSynchroniseUsers numIterations epoch iteration
       return $ JobSynchroniseUser userId
 
 dispatchJobSynchroniseUser :: UserId -> JobHandler UniWorX
-dispatchJobSynchroniseUser jUser = JobHandlerException $ do
-  userSourceConf <- getsYesod $ view _appUserAuthConf
-  case userSourceConf of
-    UserAuthConfSingleSource (AuthSourceConfLdap _ldapConf) ->
-      runDB . void . runMaybeT . handleExc $ do
-        ldapPool@(upsertUserLdapConf,_) <- MaybeT . getsYesod $ view _appLdapPool
-        user@User{userIdent = upsertUserIdent} <- MaybeT $ get jUser
-        $logInfoS "SynchroniseUser" [st|Synchronising #{upsertUserIdent} with LDAP|]
-        -- reTestAfter <- getsYesod $ view _appUserdbRetestFailover
-        -- ldapAttrs <- MaybeT $ campusUserReTest' ldapConf ((>= reTestAfter) . realToFrac) FailoverUnlimited user
-        upsertUserLdapData <- MaybeT $ ldapUser' ldapPool user
-        void . lift $ upsertUser UpsertUserSync{..} UpsertUserDataLdap{..}
-    UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) ->
-      runDB . void . runMaybeT . handleExc $ do
-        user@User{userIdent = upsertUserIdent} <- MaybeT $ get jUser
-        $logInfoS "SynchroniseUser" [st|Synchronising #{upsertUserIdent} with Azure|]
-        upsertUserAzureData <- MaybeT $ azureUser' upsertUserAzureConf user
-        void . lift $ upsertUser UpsertUserSync{..} UpsertUserDataAzure{..}
-  where
-    handleExc :: MaybeT DB a -> MaybeT DB a
-    handleExc
-      = catchMPlus (Proxy @AzureUserException)
-      . catchMPlus (Proxy @LdapUserException)
-      . catchMPlus (Proxy @UserConversionException)
+dispatchJobSynchroniseUser jUser = JobHandlerException . runDB $ do
+  User{userIdent = upsertUserIdent} <- getJust jUser
+  $logInfoS "SynchroniseUser" [st|Synchronising #{upsertUserIdent} with external sources|]
+  void $ userLookupAndUpsert (CI.original upsertUserIdent) UpsertUserSync{..}

From c9fa627651fb8ef76e16666fb40a36c0e703979f Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 09:56:54 +0100
Subject: [PATCH 136/178] chore(admin): generalize admin ldap handler for all
 source types (TODO: rename)

---
 src/Handler/Admin/Ldap.hs | 64 ++++++++++++++++++++++-----------------
 templates/ldap.hamlet     | 49 ++++++++++++++++++------------
 2 files changed, 66 insertions(+), 47 deletions(-)

diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs
index bd18d34e9..41c34afc1 100644
--- a/src/Handler/Admin/Ldap.hs
+++ b/src/Handler/Admin/Ldap.hs
@@ -2,51 +2,62 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-
-
 module Handler.Admin.Ldap
   ( getAdminLdapR
   , postAdminLdapR
   ) where
 
 import Import
--- import qualified Control.Monad.State.Class as State
--- import Data.Aeson (encode)
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
--- import qualified Data.Set  as Set
-import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,UserConversionException())
-import Handler.Utils
 
-import qualified Ldap.Client as Ldap
+import Foundation.Yesod.Auth (userLookupAndUpsert) -- decodeUserTest
+import Auth.OAuth2 (queryOAuth2User)
 import Auth.LDAP
 
+import Handler.Utils
 
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+import qualified Ldap.Client as Ldap
+
+
+-- TODO: used for every external source type => rename!
 getAdminLdapR,  postAdminLdapR :: Handler Html
 getAdminLdapR = postAdminLdapR
 postAdminLdapR = do
   ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
 
-  let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
-      procFormPerson lid = do
-        ldapPool' <- getsYesod $ view _appLdapPool
-        case ldapPool' of 
-          Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
-          Just ldapPool@(ldapConf, _) -> do 
-            addMessage Info  $ text2Html "Input for LDAP test received."
-            ldapData <- ldapUser'' ldapPool lid
-            decodedErr <- decodeUserTest UpsertUserDataLdap{ upsertUserLdapConf = ldapConf, upsertUserLdapData = concat ldapData }
-            whenIsLeft decodedErr $ addMessageI Error
-            return ldapData
-  mbLdapData <- formResultMaybe presult procFormPerson
+  let
+    presentUtf8   v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
+    presentLatin1 v = Text.intercalate ", " (                 Text.decodeLatin1 <$> v)
+
+    procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
+    procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case
+      UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of
+        AuthSourceConfAzureAdV2 AzureConf{..} -> do
+          -- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id
+          queryOAuth2User @[(Text,[ByteString])] needle >>= \case
+            Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing
+            Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
+        AuthSourceConfLdap LdapConf{ ldapConfSourceId = authSourceIdLdapHost } -> do
+          getsYesod (view _appLdapPool) >>= \case
+            Nothing -> addMessage Error (text2Html "LDAP Pool configuration missing!") >> return Nothing
+            Just pool -> do
+              ldapData <- ldapSearch pool needle
+              -- decodedErr <- decodeUserTest $ NonEmpty.singleton UpsertUserDataLdap{ upsertUserLdapHost = ldapConfSourceId, upsertUserLdapData = concat ldapData }
+              -- whenIsLeft decodedErr $ addMessageI Error
+              return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
+
+  mbData <- formResultMaybe presult procFormPerson
 
 
   ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-  let procFormUpsert :: Text -> Handler (Maybe (Either UserConversionException (Entity User)))
-      procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
-  mbLdapUpsert <- formResultMaybe uresult procFormUpsert
+  let procFormUpsert :: Text -> Handler (Maybe (Entity User))
+      procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser)
+
+  mbUpsert <- formResultMaybe uresult procFormUpsert
 
 
   actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
@@ -60,9 +71,6 @@ postAdminLdapR = do
                       { formAction = Just $ SomeRoute actionUrl
                       , formEncoding = uenctype
                       }
-        presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
-        presentLatin1 lv = Text.intercalate ", " (                 Text.decodeLatin1 <$> lv)
-
     -- TODO: use i18nWidgetFile instead if this is to become permanent
     $(widgetFile "ldap")
 
diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet
index a2b2a1533..7016383a8 100644
--- a/templates/ldap.hamlet
+++ b/templates/ldap.hamlet
@@ -1,33 +1,44 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Steffen Jost 
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 
      
-  
       
-    LDAP Person Search:
+  
      
+    Query external user databases:
     ^{personForm}
-  $maybe answers <- mbLdapData
+  $maybe responses <- mbData
     
      
-      Antwort: #
+      Responses: #
     
      
-      $forall (lk, lv) <- answers
-        $with numv <- length lv
-          
      
-            #{show lk}
-            $if 1 < numv
-              \ (#{show numv})
-          
      
-            UTF8:  #{presentUtf8 lv}
-            —
-            Latin: #{presentLatin1 lv}
+      $forall (source,responses) <- responses
+        
      
+          $case source
+            $of AuthSourceIdAzure tenantId
+              Azure Tenant ID: #
+              #{tshow tenantId}
+            $of AuthSourceIdLdap ldapHost
+              LDAP host: #
+              #{ldapHost}
+        
      
+          
      
+            $forall (k,(numv,vUtf8,vLatin1)) <- responses
+              
      
+                #{k}
+                $if 1 < numv
+                  \ (#{show numv})
+              
      
+                UTF8:  #{vUtf8}
+                —
+                Latin: #{vLatin1}
+
 
      
   
      
-    LDAP Upsert user in DB:
+    Upsert user from external database:
     ^{upsertForm}
-  $maybe answer <- mbLdapUpsert
+  $maybe response <- mbUpsert
     
      
-      Antwort: #
+      Response: #
     
      
-      #{tshow answer}
+      #{tshow response}

From a2903da109a8f2c1ec5489b2ae9c3a13e5ad1cba Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 10:40:49 +0100
Subject: [PATCH 137/178] refactor(auth): UserConversionException ->
 DecodeUserException

---
 .../categories/authorization/de-de-formal.msg | 16 ++++-----
 .../categories/authorization/en-eu.msg        | 16 ++++-----
 src/Foundation/Yesod/Auth.hs                  | 33 +++++++++----------
 3 files changed, 32 insertions(+), 33 deletions(-)

diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg
index 80657d3e5..48648198c 100644
--- a/messages/uniworx/categories/authorization/de-de-formal.msg
+++ b/messages/uniworx/categories/authorization/de-de-formal.msg
@@ -103,14 +103,14 @@ PWHashLoginTitle: Spezieller Funktionsnutzer Login
 PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden!
 DummyLoginTitle: Development-Login
 InternalLoginError: Interner Fehler beim Login
-UserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
-UserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
-UserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
-UserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
-UserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
-UserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
-UserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
-UserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
+DecodeUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
+DecodeUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
+DecodeUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
+DecodeUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
+DecodeUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
+DecodeUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
+DecodeUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
+DecodeUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
 InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht
 InvalidCredentialsADLogonFailure: Ungültiges Passwort
 InvalidCredentialsADAccountRestriction: Beschränkungen des Fraport Accounts verhindern Login
diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg
index 2519242e4..47735ffd8 100644
--- a/messages/uniworx/categories/authorization/en-eu.msg
+++ b/messages/uniworx/categories/authorization/en-eu.msg
@@ -104,14 +104,14 @@ PWHashLoginTitle: Special function user login
 PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field.
 DummyLoginTitle: Development login
 InternalLoginError: Internal error during login
-UserInvalidIdent: Could not determine unique identification during Fraport Büko login
-UserInvalidEmail: Could not determine email address during Fraport Büko login
-UserInvalidDisplayName: Could not determine display name during Fraport Büko login
-UserInvalidGivenName: Could not determine given name during Fraport Büko login
-UserInvalidSurname: Could not determine surname during Fraport Büko login
-UserInvalidTitle: Could not determine title during Fraport Büko login
-UserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
-UserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
+DecodeUserInvalidIdent: Could not determine unique identification during Fraport Büko login
+DecodeUserInvalidEmail: Could not determine email address during Fraport Büko login
+DecodeUserInvalidDisplayName: Could not determine display name during Fraport Büko login
+DecodeUserInvalidGivenName: Could not determine given name during Fraport Büko login
+DecodeUserInvalidSurname: Could not determine surname during Fraport Büko login
+DecodeUserInvalidTitle: Could not determine title during Fraport Büko login
+DecodeUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
+DecodeUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
 InvalidCredentialsADNoSuchObject: User entry does not exist
 InvalidCredentialsADLogonFailure: Invalid password
 InvalidCredentialsADAccountRestriction: Restrictions on your Fraport account prevent a login
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 2dec06d63..1c1de9262 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -7,7 +7,7 @@ module Foundation.Yesod.Auth
   , userLookupAndUpsert
   , upsertUser
   , decodeUserTest
-  , UserConversionException(..)
+  , DecodeUserException(..)
   , updateUserLanguage
   ) where
 
@@ -89,10 +89,10 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
             $logErrorS "FetchUserException" $ tshow err
             mr <- getMessageRender
             excRecovery . ServerError $ mr MsgInternalLoginError
-      , C.Handler $ \(cExc :: UserConversionException) -> do
-          $logErrorS "Auth" $ tshow cExc
+      , C.Handler $ \(dExc :: DecodeUserException) -> do
+          $logErrorS "Auth" $ tshow dExc
           mr <- getMessageRender
-          excRecovery . ServerError $ mr cExc
+          excRecovery . ServerError $ mr dExc
       ]
 
     acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
@@ -132,16 +132,15 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       -> acceptExisting
 
 
--- TODO: rename to DecodeUserException (associate with function!)
-data UserConversionException
-  = UserInvalidIdent
-  | UserInvalidEmail
-  | UserInvalidDisplayName
-  | UserInvalidGivenName
-  | UserInvalidSurname
-  | UserInvalidTitle
-  | UserInvalidFeaturesOfStudy Text
-  | UserInvalidAssociatedSchools Text
+data DecodeUserException
+  = DecodeUserInvalidIdent
+  | DecodeUserInvalidEmail
+  | DecodeUserInvalidDisplayName
+  | DecodeUserInvalidGivenName
+  | DecodeUserInvalidSurname
+  | DecodeUserInvalidTitle
+  | DecodeUserInvalidFeaturesOfStudy Text
+  | DecodeUserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Exception)
 
@@ -304,7 +303,7 @@ decodeUser now UserDefaultConf{..} upsertData = do
       , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
         -> return $ CI.mk ldapPrimaryKey''
       | otherwise
-        -> throwM UserInvalidIdent
+        -> throwM DecodeUserInvalidIdent
 
     let
       (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
@@ -437,7 +436,7 @@ decodeUserTest :: ( MonadHandler m
                   , MonadCatch m
                   )
                => NonEmpty UpsertUserData
-               -> m (Either UserConversionException (User, [Update User]))
+               -> m (Either DecodeUserException (User, [Update User]))
 decodeUserTest decodeData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
@@ -495,4 +494,4 @@ updateUserLanguage Nothing = runMaybeT $ do
   setRegisteredCookie CookieLang lang
   return lang
 
-embedRenderMessage ''UniWorX ''UserConversionException id
+embedRenderMessage ''UniWorX ''DecodeUserException id

From 96e3eb613df98573472ce21eac1f4ed20de4e5f6 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 12:10:26 +0100
Subject: [PATCH 138/178] chore(admin): merge external-user handlers (ldap,
 oauth2)

---
 .../utils/navigation/menu/de-de-formal.msg    |  5 +-
 .../uniworx/utils/navigation/menu/en-eu.msg   |  5 +-
 routes                                        | 35 ++++++-----
 src/Foundation/Navigation.hs                  | 15 +----
 src/Handler/Admin.hs                          |  5 +-
 .../Admin/{Ldap.hs => ExternalUser.hs}        | 29 ++++-----
 src/Handler/Admin/OAuth2.hs                   | 59 -------------------
 .../external-user.hamlet}                     |  0
 templates/oauth2.hamlet                       | 19 ------
 9 files changed, 39 insertions(+), 133 deletions(-)
 rename src/Handler/Admin/{Ldap.hs => ExternalUser.hs} (83%)
 delete mode 100644 src/Handler/Admin/OAuth2.hs
 rename templates/{ldap.hamlet => admin/external-user.hamlet} (100%)
 delete mode 100644 templates/oauth2.hamlet

diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg
index 78e095b6d..8bcdf9ec9 100644
--- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg
+++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -141,8 +141,7 @@ MenuSap: SAP Schnittstelle
 
 MenuAvs: AVS Schnittstelle
 MenuAvsSynchError: AVS Problemübersicht
-MenuLdap !ident-ok: LDAP
-MenuOAuth2 !ident-ok: OAuth2
+MenuExternalUser: Externe Benutzer
 MenuApc: Druckerei
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg
index bb085c38e..1b59f781a 100644
--- a/messages/uniworx/utils/navigation/menu/en-eu.msg
+++ b/messages/uniworx/utils/navigation/menu/en-eu.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -141,8 +141,7 @@ MenuSap: SAP Interface
 
 MenuAvs: AVS Interface
 MenuAvsSynchError: AVS Problem Overview
-MenuLdap: LDAP
-MenuOAuth2: OAuth2
+MenuExternalUser: External users
 MenuApc: Printing
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
diff --git a/routes b/routes
index 2376c33af..ec953250d 100644
--- a/routes
+++ b/routes
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -30,8 +30,8 @@
 --    !capacity       -- course this route is associated with has at least one unit of participant capacity
 --    !empty          -- course this route is associated with has no participants whatsoever
 --
---    !is-ldap        -- user has authentication mode set to LDAP
---    !is-pw-hash     -- user has authentication mode set to PWHash
+--    !is-external    -- user can login using external sources
+--    !is-internal    -- user can login using internal credentials
 --
 --    !materials      -- only if course allows all materials to be free (no meaning outside of courses)
 --    !time           -- access depends on time somehow
@@ -59,24 +59,23 @@
 /users/#CryptoUUIDUser/password       UserPasswordR               GET POST   !selfANDis-pw-hash
 !/users/functionary-invite/new        AdminNewFunctionaryInviteR  GET POST
 !/users/functionary-invite            AdminFunctionaryInviteR     GET POST
-!/users/add                   AdminUserAddR    GET POST
-/admin                        AdminR           GET
-/admin/test                   AdminTestR       GET POST
-/admin/test/pdf               AdminTestPdfR    GET
-/admin/errMsg                 AdminErrMsgR     GET POST
-/admin/tokens                 AdminTokensR     GET POST
-/admin/crontab                AdminCrontabR    GET
-/admin/crontab/jobs           AdminJobsR       GET POST
-/admin/avs                    AdminAvsR        GET POST
-/admin/avs/#CryptoUUIDUser    AdminAvsUserR    GET
-/admin/ldap                   AdminLdapR       GET POST
-/admin/oauth2                 AdminOAuth2R     GET POST
-/admin/problems               AdminProblemsR			 GET
+!/users/add                   AdminUserAddR      GET POST
+/admin                        AdminR             GET
+/admin/test                   AdminTestR         GET POST
+/admin/test/pdf               AdminTestPdfR      GET
+/admin/errMsg                 AdminErrMsgR       GET POST
+/admin/tokens                 AdminTokensR       GET POST
+/admin/crontab                AdminCrontabR      GET
+/admin/crontab/jobs           AdminJobsR         GET POST
+/admin/avs                    AdminAvsR          GET POST
+/admin/avs/#CryptoUUIDUser    AdminAvsUserR      GET
+/admin/external-user          AdminExternalUserR GET POST
+/admin/problems               AdminProblemsR     GET
 /admin/problems/no-contact    ProblemUnreachableR  GET
 /admin/problems/no-avs-id     ProblemWithoutAvsId  GET
 /admin/problems/r-without-f   ProblemFbutNoR       GET
-/admin/problems/avs  					ProblemAvsSynchR 		 GET POST
-/admin/problems/avs/errors		ProblemAvsErrorR 		 GET
+/admin/problems/avs           ProblemAvsSynchR     GET POST
+/admin/problems/avs/errors    ProblemAvsErrorR 	   GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index 75cb1fdf7..8f3f58467 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -115,8 +115,7 @@ breadcrumb AdminCrontabR        = i18nCrumb MsgBreadcrumbAdminCrontab     $ Just
 breadcrumb AdminJobsR           = i18nCrumb MsgBreadcrumbAdminJobs        $ Just AdminCrontabR
 breadcrumb AdminAvsR            = i18nCrumb MsgMenuAvs                    $ Just AdminR
 breadcrumb AdminAvsUserR{}      = i18nCrumb MsgAvsPersonInfo              $ Just AdminAvsR
-breadcrumb AdminLdapR           = i18nCrumb MsgMenuLdap                   $ Just AdminR
-breadcrumb AdminOAuth2R         = i18nCrumb MsgMenuOAuth2                 $ Just AdminR
+breadcrumb AdminExternalUserR   = i18nCrumb MsgMenuExternalUser           $ Just AdminR
 breadcrumb AdminProblemsR       = i18nCrumb MsgProblemsHeading            $ Just AdminR
 breadcrumb ProblemUnreachableR  = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR
 breadcrumb ProblemWithoutAvsId  = i18nCrumb MsgProblemsNoAvsIdHeading     $ Just AdminProblemsR
@@ -855,16 +854,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navForceActive = False
               }
           , NavLink
-              { navLabel       = MsgMenuLdap
-              , navRoute       = AdminLdapR
-              , navAccess'     = NavAccessTrue
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuOAuth2
-              , navRoute       = AdminOAuth2R
+              { navLabel       = MsgMenuExternalUser
+              , navRoute       = AdminExternalUserR
               , navAccess'     = NavAccessTrue
               , navType        = NavTypeLink { navModal = False }
               , navQuick'      = mempty
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index a64620899..34811f1fd 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen , Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -30,8 +30,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.Tokens as Handler.Admin
 import Handler.Admin.Crontab as Handler.Admin
 import Handler.Admin.Avs as Handler.Admin
-import Handler.Admin.Ldap as Handler.Admin
-import Handler.Admin.OAuth2 as Handler.Admin
+import Handler.Admin.ExternalUser as Handler.Admin
 
 
 getAdminR :: Handler Html
diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/ExternalUser.hs
similarity index 83%
rename from src/Handler/Admin/Ldap.hs
rename to src/Handler/Admin/ExternalUser.hs
index 41c34afc1..1d5d11ab4 100644
--- a/src/Handler/Admin/Ldap.hs
+++ b/src/Handler/Admin/ExternalUser.hs
@@ -1,10 +1,10 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-module Handler.Admin.Ldap
-  ( getAdminLdapR
-  , postAdminLdapR
+module Handler.Admin.ExternalUser
+  ( getAdminExternalUserR
+  , postAdminExternalUserR
   ) where
 
 import Import
@@ -21,11 +21,10 @@ import qualified Data.Text.Encoding as Text
 import qualified Ldap.Client as Ldap
 
 
--- TODO: used for every external source type => rename!
-getAdminLdapR,  postAdminLdapR :: Handler Html
-getAdminLdapR = postAdminLdapR
-postAdminLdapR = do
-  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> 
+getAdminExternalUserR,  postAdminExternalUserR :: Handler Html
+getAdminExternalUserR = postAdminExternalUserR
+postAdminExternalUserR = do
+  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminExternalUserLookup"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
 
   let
@@ -52,7 +51,7 @@ postAdminLdapR = do
   mbData <- formResultMaybe presult procFormPerson
 
 
-  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> 
+  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
   let procFormUpsert :: Text -> Handler (Maybe (Entity User))
       procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser)
@@ -60,9 +59,9 @@ postAdminLdapR = do
   mbUpsert <- formResultMaybe uresult procFormUpsert
 
 
-  actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
-  siteLayoutMsg MsgMenuLdap $ do
-    setTitleI MsgMenuLdap
+  actionUrl <- fromMaybe AdminExternalUserR <$> getCurrentRoute
+  siteLayoutMsg MsgMenuExternalUser $ do
+    setTitleI MsgMenuExternalUser
     let personForm = wrapForm pwidget def
                       { formAction = Just $ SomeRoute actionUrl
                       , formEncoding = penctype
@@ -71,6 +70,4 @@ postAdminLdapR = do
                       { formAction = Just $ SomeRoute actionUrl
                       , formEncoding = uenctype
                       }
-    -- TODO: use i18nWidgetFile instead if this is to become permanent
-    $(widgetFile "ldap")
-
+    $(widgetFile "admin/external-user")
diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs
deleted file mode 100644
index 1face989f..000000000
--- a/src/Handler/Admin/OAuth2.hs
+++ /dev/null
@@ -1,59 +0,0 @@
--- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel ,David Mosbach 
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Admin.OAuth2
-  ( getAdminOAuth2R
-  , postAdminOAuth2R
-  ) where
-
-import Import
--- import qualified Data.CaseInsensitive as CI
-import Data.Aeson.Encode.Pretty (encodePretty)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as T
---import qualified Data.Text.Encoding as Text
---import Foundation.Yesod.Auth (CampusUserConversionException()) 
-import Handler.Utils
-
-import Auth.OAuth2 (queryOAuth2User)
-
-
-getAdminOAuth2R,   postAdminOAuth2R :: Handler Html
-getAdminOAuth2R  = postAdminOAuth2R
-postAdminOAuth2R = do
-   ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> 
-     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
- 
-   let procFormPerson :: Text -> Handler (Maybe T.Text)
-       procFormPerson lid = do --return . Just $ "Mock reply for id " <> lid
-         eUserData <- queryOAuth2User @Value lid
-         case eUserData of
-          Left e -> throwM e
-          Right userData -> return . Just . T.decodeUtf8 $ encodePretty userData
-   mOAuth2Data <- formResultMaybe presult procFormPerson
- 
-   --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> 
-   --  flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-
-   --let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
-   --    procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
-   --mbLdapUpsert <- formResultMaybe uresult procFormUpsert
- 
- 
-   actionUrl <- fromMaybe AdminOAuth2R <$> getCurrentRoute
-   siteLayoutMsg MsgMenuOAuth2 $ do
-     setTitleI MsgMenuOAuth2
-     let personForm = wrapForm pwidget def
-                       { formAction = Just $ SomeRoute actionUrl
-                       , formEncoding = penctype
-                       }
-         --upsertForm = wrapForm uwidget def 
-         --              { formAction = Just $ SomeRoute actionUrl
-         --              , formEncoding = uenctype
-         --              }
-         --presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
-         --presentLatin1 lv = Text.intercalate ", " (                 Text.decodeLatin1 <$> lv)
- 
-     -- TODO: use i18nWidgetFile instead if this is to become permanent
-     $(widgetFile "oauth2")
diff --git a/templates/ldap.hamlet b/templates/admin/external-user.hamlet
similarity index 100%
rename from templates/ldap.hamlet
rename to templates/admin/external-user.hamlet
diff --git a/templates/oauth2.hamlet b/templates/oauth2.hamlet
deleted file mode 100644
index 90711a799..000000000
--- a/templates/oauth2.hamlet
+++ /dev/null
@@ -1,19 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2023 David Mosbach 
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-
      
-  
       
-    OAuth2 User Search:
-    ^{personForm}
-  $maybe answers <- mOAuth2Data
-    
      
-      Antwort: #
-    
      
-          
      
-            
      -              #{answers}
-          
      
-            

From 51298ba726ecfe4e0e1ca2303167422018b86bd5 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 19:05:58 +0100
Subject: [PATCH 139/178] chore: make fetch and upsert results Maybe

---
 src/Foundation/Yesod/Auth.hs      | 98 +++++++++++++------------------
 src/Handler/Admin/ExternalUser.hs |  2 +-
 src/Handler/Utils/Avs.hs          | 15 +++--
 src/Handler/Utils/Users.hs        | 30 ++++------
 4 files changed, 64 insertions(+), 81 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 1c1de9262..2c0ffc3ef 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -5,7 +5,7 @@
 module Foundation.Yesod.Auth
   ( authenticate
   , userLookupAndUpsert
-  , upsertUser
+  , upsertUser, maybeUpsertUser
   , decodeUserTest
   , DecodeUserException(..)
   , updateUserLanguage
@@ -22,7 +22,7 @@ import Foundation.Type
 import Foundation.Types
 import Foundation.I18n
 
-import Handler.Utils.Profile
+-- import Handler.Utils.Profile
 import Handler.Utils.LdapSystemFunctions
 import Handler.Utils.Memcached
 import Foundation.Authorization (AuthorizationCacheKey(..))
@@ -112,22 +112,12 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
   flip catches excHandlers $ if
     | not isDummy, not isOther
-    -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
-    , Just upsertMode' <- upsertMode -> do
-        userData <- fetchUserData Creds{..}
+    , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case
+      Just userData -> do
         $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
         Authenticated . entityKey <$> upsertUser upsertMode' userData
-        -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
-        -- upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
-        -- $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
-        -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
-    -- | not isDummy, not isOther
-    -- , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
-    -- , Just upsertMode' <- upsertMode -> do
-    --     ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-    --     upsertUserLdapData <- ldapUser ldapPool Creds{..}
-    --     $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
-    --     Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
+      Nothing
+        -> throwM FetchUserDataNoResult
     | otherwise
       -> acceptExisting
 
@@ -176,9 +166,9 @@ userLookupAndUpsert :: forall m.
                        )
                     => Text
                     -> UpsertUserMode
-                    -> SqlPersistT m (Entity User)
+                    -> SqlPersistT m (Maybe (Entity User))
 userLookupAndUpsert credsIdent mode =
-  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= upsertUser mode
+  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode
 
 
 data FetchUserDataException
@@ -197,23 +187,23 @@ fetchUserData :: forall m site.
                  , MonadUnliftIO m
                  )
               => Creds site
-              -> SqlPersistT m (NonEmpty UpsertUserData)
-fetchUserData creds@Creds{..} = do
+              -> SqlPersistT m (Maybe (NonEmpty UpsertUserData))
+fetchUserData Creds{..} = do
   userAuthConf <- getsYesod $ view _appUserAuthConf
   now <- liftIO getCurrentTime
 
-  results :: NonEmpty UpsertUserData <- case userAuthConf of
-    UserAuthConfSingleSource{..} -> (:| []) <$> case userAuthConfSingleSource of
+  results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of
+    UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of
       AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
         queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
-          Right upsertUserAzureData -> return UpsertUserDataAzure{..}
-          Left _ -> throwM FetchUserDataNoResult
-      AuthSourceConfLdap LdapConf{..} -> do
-        ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool
-        UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds
+          Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..}
+          Left _ -> return Nothing
+      AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case
+        Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent
+        Nothing -> throwM FetchUserDataException
 
   -- insert ExternalUser entries for each fetched dataset
-  forM_ results $ \res ->
+  whenIsJust results $ \ress -> forM_ ress $ \res ->
     let externalUserUser =  error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId
         externalUserLastSync = now
         (externalUserData, externalUserSource) = case res of
@@ -225,15 +215,16 @@ fetchUserData creds@Creds{..} = do
 
 
 -- | Upsert User and related auth in DB according to given external source data (does not query source itself)
-upsertUser :: forall m.
-              ( MonadHandler m
-              , HandlerSite m ~ UniWorX
-              , MonadCatch m
-              )
-           => UpsertUserMode
-           -> NonEmpty UpsertUserData
-           -> SqlPersistT m (Entity User)
-upsertUser _upsertMode upsertData = do
+maybeUpsertUser :: forall m.
+                   ( MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   , MonadCatch m
+                   )
+                => UpsertUserMode
+                -> Maybe (NonEmpty UpsertUserData)
+                -> SqlPersistT m (Maybe (Entity User))
+maybeUpsertUser _upsertMode Nothing = return Nothing
+maybeUpsertUser _upsertMode (Just upsertData) = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
@@ -242,27 +233,10 @@ upsertUser _upsertMode upsertData = do
 
   oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
 
-  user@(Entity userId userRec) <- case oldUsers of
+  user@(Entity userId _userRec) <- case oldUsers of
     [oldUserId] -> updateGetEntity oldUserId userUpdate
     _other      -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
 
-  -- sets display name
-  -- TODO: use display name from external source, if possible
-  unless (validDisplayName (newUser ^. _userTitle)
-                           (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname)
-                           (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
-
-  -- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure)
-  -- when (validEmail' (userRec ^. _userEmail)) $ do
-  --   let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
-  --             ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-  --   unless (null emUps) $ update userId emUps
-  --   -- Attempt to update ident, too:
-  --   unless (validEmail' (userRec ^. _userIdent)) $
-  --     void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
-
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
     userSystemFunctions' = concat $ upsertData <&> \case
@@ -283,7 +257,19 @@ upsertUser _upsertMode upsertData = do
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  return user
+  return $ Just user
+
+upsertUser :: forall m.
+              ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              , MonadCatch m
+              )
+           => UpsertUserMode
+           -> NonEmpty UpsertUserData
+           -> SqlPersistT m (Entity User)
+upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case
+  Nothing -> error "upsertUser: No user result from maybeUpsertUser!"
+  Just user -> return user
 
 
 decodeUser :: ( MonadThrow m
diff --git a/src/Handler/Admin/ExternalUser.hs b/src/Handler/Admin/ExternalUser.hs
index 1d5d11ab4..2a7226765 100644
--- a/src/Handler/Admin/ExternalUser.hs
+++ b/src/Handler/Admin/ExternalUser.hs
@@ -54,7 +54,7 @@ postAdminExternalUserR = do
   ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
   let procFormUpsert :: Text -> Handler (Maybe (Entity User))
-      procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser)
+      procFormUpsert lid = runDB (userLookupAndUpsert lid UpsertUserGuessUser)
 
   mbUpsert <- formResultMaybe uresult procFormUpsert
 
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 3743dcd8f..222ec4ba6 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -355,9 +355,9 @@ guessAvsUser someid = do
             _              -> return Nothing
         uid -> return uid
     Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case
-      Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> 
+      Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> 
         maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo))
-      Right Entity{entityKey=uid} -> return $ Just uid
+      Right (Just Entity{entityKey=uid}) -> return $ Just uid
       other -> do -- attempt to recover by trying other ids
         whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all      
         runDB . runMaybeT $ 
@@ -370,7 +370,7 @@ upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
 upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid    -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
 upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
   try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case
-    Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
+    Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
     other -> do -- attempt to recover by trying other ids
       whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
       apid <- runDB . runMaybeT $ do
@@ -419,13 +419,16 @@ upsertAvsUserById api = do
               [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing)
               (_:_) -> throwM $ AvsUserAmbiguous api
               [] -> do
-                upsRes :: Either SomeException (Entity User)
+                upsRes :: Either SomeException (Maybe (Entity User))
                   <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate
                 $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
                 case upsRes of
-                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right Nothing -> do
+                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases"
+                    return mbuid -- == Nothing -- user could not be created somehow
                   Left err -> do 
-                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err
+                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err
                     return mbuid -- == Nothing -- user could not be created somehow
       (Just Entity{ entityKey = uaid }, _) -> do
         update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 2580d1700..0e59307d7 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -24,8 +24,7 @@ module Handler.Utils.Users
   ) where
 
 import Import
-import Auth.LDAP (ldapUserMatr')
-import Foundation.Yesod.Auth (upsertUser)
+import Foundation.Yesod.Auth (userLookupAndUpsert)
 
 import Crypto.Hash (hashlazy)
 
@@ -192,7 +191,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
       GuessUserSurname                userSurname'       -> user E.^. UserSurname        `containsAsSet` userSurname'
       GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'
 
-    go didLdap = do
+    go didUpsert = do
       let retrieveUsers = E.select . EL.from $ \user -> do
             E.where_ . E.or $ map (E.and . map (toSql user)) criteria
             when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
@@ -234,12 +233,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | EQ <- x `closeness` x' = x : takeClosest (x':xs)
             | otherwise = [x]
 
-          -- TODO: Generalize
-          doLdap userMatr = do
-            ldapPool' <- getsYesod $ view _appLdapPool
-            fmap join . for ldapPool' $ \ldapPool@(LdapConf{ ldapConfSourceId = upsertUserLdapHost },_) -> do
-              ldapData <- ldapUserMatr' ldapPool userMatr
-              for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser $ UpsertUserDataLdap{..} :| []
+          doUpsert = flip userLookupAndUpsert UpsertUserGuessUser
 
       let
         getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
@@ -255,25 +249,25 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | otherwise                        = Nothing
           getTermMatrAux acc (_:xs) = getTermMatrAux acc xs
 
-        convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
-        convertLdapResults []  = Nothing
-        convertLdapResults [x] = Just $ Right x
-        convertLdapResults xs  = Just $ Left $ NonEmpty.fromList xs
+        convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
+        convertUpsertResults []  = Nothing
+        convertUpsertResults [x] = Just $ Right x
+        convertUpsertResults xs  = Just $ Left $ NonEmpty.fromList xs
 
       if
         | [x] <- users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
           -> return $ Just $ Right x
         | x : x' : _ <- users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
         , GT <- x `closeness` x'
           -> return $ Just $ Right x
         | xs@(x:_:_) <- takeClosest users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
           -> return $ Just $ Left $ NonEmpty.fromList xs
-        | not didLdap
+        | not didUpsert
         , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
-          -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
+          -> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . catMaybes
         | otherwise
           -> return Nothing
 

From 708320e067ec715bff8409979064cb6e72a059de Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 20:04:19 +0100
Subject: [PATCH 140/178] chore(auth): change user identification to UserIdent
 for ExternalUser entries

---
 models/users.model              |  2 +-
 src/Foundation/Authorization.hs |  4 ++--
 src/Foundation/Yesod/Auth.hs    | 18 ++++++++++++++----
 src/Handler/Profile.hs          |  2 +-
 src/Handler/SAP.hs              |  2 +-
 src/Jobs/HealthReport.hs        |  3 ++-
 6 files changed, 21 insertions(+), 10 deletions(-)

diff --git a/models/users.model b/models/users.model
index fdbdb6fcf..39ea0ae09 100644
--- a/models/users.model
+++ b/models/users.model
@@ -56,7 +56,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
 
 -- | User data fetched from external user sources, used for authentication and data queries
 ExternalUser
-    user      UserId -- TODO: use UserIdent or Text instead; not every external user may have ever logged in (or needs to), i.e. users that have been queried in admin handler!
+    user      UserIdent
     source    AuthSourceIdent              -- Identifier of the external source in the config
     data      Value "default='{}'::jsonb"  -- Raw user data from external source -- TODO: maybe make Maybe, iff the source only ever responds with "success"?
     lastSync  UTCTime                      -- When was the external source last queried?
diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index de4575a8d..507c0619e 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -1533,8 +1533,8 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
   let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
   maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
-    Entity uid _ <- MaybeT $ getEntity referencedUser'
-    guardM . lift $ exists [ ExternalUserUser ==. uid, ExternalUserSource <-. availableSources ]
+    Entity _ User{userIdent} <- MaybeT $ getEntity referencedUser'
+    guardM . lift $ exists [ ExternalUserUser ==. userIdent, ExternalUserSource <-. availableSources ]
   return Authorized
 tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 2c0ffc3ef..94573e8fd 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -203,13 +203,23 @@ fetchUserData Creds{..} = do
         Nothing -> throwM FetchUserDataException
 
   -- insert ExternalUser entries for each fetched dataset
-  whenIsJust results $ \ress -> forM_ ress $ \res ->
-    let externalUserUser =  error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId
-        externalUserLastSync = now
+  whenIsJust results $ \ress -> forM_ ress $ \res -> do
+    let externalUserLastSync = now
         (externalUserData, externalUserSource) = case res of
           UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
           UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
-     in void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
+    externalUserUser <- if
+      | UpsertUserDataAzure{..} <- res
+      , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> \(t,bs) -> (t, filter (not . ByteString.null) bs)
+      , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
+        -> return $ CI.mk azureUserPrincipalName'
+      | UpsertUserDataLdap{..} <- res
+      , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> \(t,bs) -> (t, filter (not . ByteString.null) bs)
+      , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
+        -> return $ CI.mk ldapPrimaryKey'
+      | otherwise
+        -> throwM DecodeUserInvalidIdent
+    void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
 
   return results
 
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 8365d8b07..a29a60933 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -584,7 +584,7 @@ makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   now <- liftIO getCurrentTime
   avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
-  externalUsers <- (\(Entity _ ExternalUser{..}) -> ("" :: Text, externalUserSource, externalUserLastSync)) <<$>> selectList [ ExternalUserUser ==. uid ] [] -- TODO: define and use user identification in ExternalUser model
+  externalUsers <- (\(Entity _ ExternalUser{..}) -> (externalUserUser, externalUserSource, externalUserLastSync)) <<$>> selectList [ ExternalUserUser ==. userIdent ] []
 
   -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs
index a04ba50ab..327900b59 100644
--- a/src/Handler/SAP.hs
+++ b/src/Handler/SAP.hs
@@ -120,7 +120,7 @@ getQualificationSAPDirectR = do
          E.&&. E.isJust (user E.^. UserCompanyPersonalNumber)
     E.where_ . E.exists $ do
       externalUser <- E.from $ E.table @ExternalUser
-      E.where_ $ externalUser E.^. ExternalUserUser     E.==.  user E.^. UserId
+      E.where_ $ externalUser E.^. ExternalUserUser     E.==.  user E.^. UserIdent
            E.&&. externalUser E.^. ExternalUserSource  `E.in_` E.valList ldapSources
            E.&&. externalUser E.^. ExternalUserLastSync E.>=.  E.val ldapCutoff
     E.groupBy ( user      E.^. UserCompanyPersonalNumber
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 0752cac76..8e2da381a 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -107,6 +107,7 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
     getsYesod $ (== clusterId) . appClusterID
 
 
+-- TODO: generalize health check
 dispatchHealthCheckLDAPAdmins :: Handler HealthReport
 dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
   ldapPool' <- getsYesod appLdapPool
@@ -121,7 +122,7 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
         E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
         E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
         E.where_ . E.exists . E.from $ \externalUser -> E.where_ $
-                externalUser E.^. ExternalUserUser E.==. user E.^. UserId
+                externalUser E.^. ExternalUserUser E.==. user E.^. UserIdent
           E.&&. externalUser E.^. ExternalUserSource `E.in_` E.valList currentLdapSources
         return $ user E.^. UserIdent
       for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do

From e1ebd528b83359d26a6ad139cc95fc7fd7089a60 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 8 Mar 2024 21:16:16 +0100
Subject: [PATCH 141/178] chore(auth): use available sources in AuthIsExternal
 access pred

---
 src/Foundation/Authorization.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index 507c0619e..770ef64f9 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -1531,7 +1531,10 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu
     CourseR _ _ _ (CUserR cID) -> return cID
     _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents
+  availableSources <- getsYesod (view _appUserAuthConf) >>= \case
+    UserAuthConfSingleSource{..} -> return . singleton $ case userAuthConfSingleSource of
+      AuthSourceConfAzureAdV2 AzureConf{..} -> AuthSourceIdAzure azureConfTenantId
+      AuthSourceConfLdap      LdapConf{..}  -> AuthSourceIdLdap  ldapConfSourceId
   maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
     Entity _ User{userIdent} <- MaybeT $ getEntity referencedUser'
     guardM . lift $ exists [ ExternalUserUser ==. userIdent, ExternalUserSource <-. availableSources ]

From 1e5c4df163bb14f29b835435fb62ada26eb6dd1c Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Sun, 10 Mar 2024 19:43:54 +0000
Subject: [PATCH 142/178] chore(auth): fix single sign out redirect route

---
 .../categories/authorization/de-de-formal.msg      |  1 +
 .../uniworx/categories/authorization/en-eu.msg     |  1 +
 routes                                             |  3 ++-
 src/Auth/OAuth2.hs                                 |  1 +
 src/Foundation/Navigation.hs                       |  1 +
 src/Handler/SingleSignOut.hs                       | 14 +++++++++++---
 6 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg
index 4c0773001..667051a51 100644
--- a/messages/uniworx/categories/authorization/de-de-formal.msg
+++ b/messages/uniworx/categories/authorization/de-de-formal.msg
@@ -140,4 +140,5 @@ FormHoneypotComment: Kommentar
 FormHoneypotCommentPlaceholder: Kommentar
 FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus
 
+Logout: Abmeldung
 SingleSignOut: Abmeldung bei Azure
diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg
index 7dc17b924..f31413299 100644
--- a/messages/uniworx/categories/authorization/en-eu.msg
+++ b/messages/uniworx/categories/authorization/en-eu.msg
@@ -141,4 +141,5 @@ FormHoneypotComment: Comment
 FormHoneypotCommentPlaceholder: Comment
 FormHoneypotFilled: Please do not fill in any of the hidden fields
 
+Logout: Logout
 SingleSignOut: Azure logout
diff --git a/routes b/routes
index e42a707e5..13f6914f9 100644
--- a/routes
+++ b/routes
@@ -46,7 +46,8 @@
 /static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free
 
-/ssout SSOutR  GET !free -- single sign-out (OIDC)
+/logout       SOutR  GET !free
+/logout/ssout SSOutR GET !free -- single sign-out (OIDC)
 
 /metrics     MetricsR GET																			!free -- verify if this can be free
 
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index c85af461b..5ed9921e2 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -167,5 +167,6 @@ singleSignOut mRedirect = do
       endpoint = case mRedirect of
         Just r -> base <> "?post_logout_redirect_uri=" <> r
         Nothing -> base
+  $logErrorS "\n\27[31mSSO\27[0m" endpoint 
   redirect endpoint
 
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index c0a642a2e..b37d51416 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -73,6 +73,7 @@ breadcrumb :: ( BearerAuthSite UniWorX
            => Route UniWorX
            -> m Breadcrumb
 breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just NewsR
+breadcrumb SOutR            = i18nCrumb MsgLogout              Nothing
 breadcrumb SSOutR           = i18nCrumb MsgSingleSignOut       Nothing
 breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
 breadcrumb (WellKnownR _)   = i18nCrumb MsgBreadcrumbWellKnown Nothing
diff --git a/src/Handler/SingleSignOut.hs b/src/Handler/SingleSignOut.hs
index 44ec813a2..8b89a19d0 100644
--- a/src/Handler/SingleSignOut.hs
+++ b/src/Handler/SingleSignOut.hs
@@ -3,7 +3,8 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Handler.SingleSignOut
-  ( getSSOutR
+  ( getSOutR
+  , getSSOutR
   ) where
 
 import Import
@@ -11,13 +12,20 @@ import Auth.OAuth2 (singleSignOut)
 import qualified Network.Wai as W
 
 
+getSOutR :: Handler Html
+getSOutR = do
+  $logErrorS "\27[31mSOut\27[0m" "Redirect to LogoutR"
+  redirect $ AuthR LogoutR
+
 getSSOutR :: Handler Html
 getSSOutR = do
   app <- getYesod
-  let logoutR = intercalate "/" . fst . renderRoute $ AuthR LogoutR
+  let redir = intercalate "/" . fst . renderRoute $ SOutR
       root = case approot of
         ApprootRequest f -> f app W.defaultRequest
         _ -> error "approt implementation changed"
+      url = decodeUtf8 . urlEncode True . encodeUtf8 $ root <> "/" <> redir
   AppSettings{..} <- getsYesod appSettings'
-  if appSingleSignOn then singleSignOut (Just $ root <> "/" <> logoutR) else redirect (AuthR LogoutR)
+  $logErrorS "\27[31mSSOut\27[0m" "Redirect to auth server"
+  if appSingleSignOn then singleSignOut (Just url) else redirect (AuthR LogoutR)
 

From 4c109538eeefa1125bb81539be5d69756b2379e6 Mon Sep 17 00:00:00 2001
From: David Mosbach 
Date: Sun, 10 Mar 2024 22:15:20 +0000
Subject: [PATCH 143/178] chore(auth): new 'Account' section

---
 .../utils/navigation/menu/de-de-formal.msg    |  3 +-
 .../uniworx/utils/navigation/menu/en-eu.msg   |  3 +-
 shell.nix                                     |  2 +-
 src/Foundation/Navigation.hs                  | 65 +++++++++----------
 src/Utils/Icon.hs                             |  4 +-
 5 files changed, 38 insertions(+), 39 deletions(-)

diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg
index 78e095b6d..77e7baa57 100644
--- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg
+++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,David Mosbach 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -24,6 +24,7 @@ MenuPayments: Zahlungsbedingungen
 MenuInstance: Instanz-Identifikation
 MenuHealth: Instanz-Zustand
 MenuHelp: Hilfe
+MenuAccount: Konto
 MenuProfile: Anpassen
 MenuLogin !ident-ok: Login
 MenuLogout !ident-ok: Logout
diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg
index bb085c38e..f4d48aa93 100644
--- a/messages/uniworx/utils/navigation/menu/en-eu.msg
+++ b/messages/uniworx/utils/navigation/menu/en-eu.msg
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,David Mosbach 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -24,6 +24,7 @@ MenuPayments: Payment Terms
 MenuInstance: Instance identification
 MenuHealth: Instance health
 MenuHelp: Support
+MenuAccount: Account
 MenuProfile: Settings
 MenuLogin: Login
 MenuLogout: Logout
diff --git a/shell.nix b/shell.nix
index 48d9cc57e..a5ca0056c 100644
--- a/shell.nix
+++ b/shell.nix
@@ -9,7 +9,7 @@ let
 
   haskellPackages = pkgs.haskellPackages;
 
-  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=83d99e55303f5b1cd6cde30b2936d61419268f8c&ref=oidc").packages.x86_64-linux;
+  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=7b995e6cffa963a24eb5d0373b2d29089533284f&ref=main").packages.x86_64-linux;
 
 
   oauth2MockServer = oauth2Flake.default;
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index b37d51416..7a38e0459 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -543,42 +543,37 @@ defaultLinks :: ( MonadHandler m
                 , BearerAuthSite UniWorX
                 ) => m [Nav]
 defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
-  [ return NavHeader
+  [ return NavHeaderContainer
       { navHeaderRole = NavHeaderSecondary
-      , navIcon       = IconMenuLogout
-      , navLink       = NavLink
-        { navLabel       = MsgMenuLogout
-        , navRoute       = SSOutR -- AuthR LogoutR
-        , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderSecondary
-      , navIcon       = IconMenuLogin
-      , navLink       = NavLink
-        { navLabel       = MsgMenuLogin
-        , navRoute       = AuthR LoginR
-        , navAccess'     = NavAccessHandler $ is _Nothing <$> maybeAuthId
-        , navType        = NavTypeLink { navModal = True }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderSecondary
-      , navIcon       = IconMenuProfile
-      , navLink       = NavLink
-        { navLabel       = MsgMenuProfile
-        , navRoute       = ProfileR
-        , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
+      , navLabel      = SomeMessage MsgMenuAccount
+      , navIcon       = IconMenuAccount
+      , navChildren   =
+          [ NavLink
+              { navLabel       = MsgMenuLogout
+              , navRoute       = SSOutR -- AuthR LogoutR
+              , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuLogin
+              , navRoute       = AuthR LoginR
+              , navAccess'     = NavAccessHandler $ is _Nothing <$> maybeAuthId
+              , navType        = NavTypeLink { navModal = True }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuProfile
+              , navRoute       = ProfileR
+              , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          ]
+  }
   , do
       mCurrentRoute <- getCurrentRoute
 
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index 07804c015..1f72ea042 100644
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost ,David Mosbach 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -81,6 +81,7 @@ data Icon
   | IconNavContainerClose | IconPageActionChildrenClose
   | IconMenuNews
   | IconMenuHelp
+  | IconMenuAccount
   | IconMenuProfile
   | IconMenuLogin | IconMenuLogout
   | IconBreadcrumbsHome
@@ -173,6 +174,7 @@ iconText = \case
     IconPageActionChildrenClose -> "chevron-up"
     IconMenuNews                -> "megaphone"
     IconMenuHelp                -> "question"
+    IconMenuAccount             -> "user"
     IconMenuProfile             -> "cogs"
     IconMenuLogin               -> "sign-in-alt"
     IconMenuLogout              -> "sign-out-alt"

From 504490f5938e5dac7bfed686bb3f5f955375308b Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 11 Mar 2024 11:09:59 +0100
Subject: [PATCH 144/178] chore(admin): switch to generic Aeson Value for oauth
 response parsing

---
 src/Handler/Admin/ExternalUser.hs    | 23 ++++++++++++-----------
 src/Ldap/Client/Instances.hs         |  4 ++++
 templates/admin/external-user.hamlet | 22 ++++++++++++----------
 3 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/src/Handler/Admin/ExternalUser.hs b/src/Handler/Admin/ExternalUser.hs
index 2a7226765..fc67a6616 100644
--- a/src/Handler/Admin/ExternalUser.hs
+++ b/src/Handler/Admin/ExternalUser.hs
@@ -15,10 +15,9 @@ import Auth.LDAP
 
 import Handler.Utils
 
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-
-import qualified Ldap.Client as Ldap
+import Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.Text.Lazy as Lazy
+import qualified Data.Text.Lazy.Encoding as Lazy
 
 
 getAdminExternalUserR,  postAdminExternalUserR :: Handler Html
@@ -28,25 +27,27 @@ postAdminExternalUserR = do
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
 
   let
-    presentUtf8   v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
-    presentLatin1 v = Text.intercalate ", " (                 Text.decodeLatin1 <$> v)
+    -- presentUtf8   v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
+    -- presentLatin1 v = Text.intercalate ", " (                 Text.decodeLatin1 <$> v)
 
-    procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
+    procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent,Lazy.Text)]) -- (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
     procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case
       UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of
         AuthSourceConfAzureAdV2 AzureConf{..} -> do
           -- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id
-          queryOAuth2User @[(Text,[ByteString])] needle >>= \case
+          queryOAuth2User @Value needle >>= \case
             Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing
-            Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
-        AuthSourceConfLdap LdapConf{ ldapConfSourceId = authSourceIdLdapHost } -> do
+            Right azureResponse -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) . Lazy.decodeUtf8 $ encodePretty azureResponse
+            -- Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
+        AuthSourceConfLdap LdapConf{..} -> do
           getsYesod (view _appLdapPool) >>= \case
             Nothing -> addMessage Error (text2Html "LDAP Pool configuration missing!") >> return Nothing
             Just pool -> do
               ldapData <- ldapSearch pool needle
               -- decodedErr <- decodeUserTest $ NonEmpty.singleton UpsertUserDataLdap{ upsertUserLdapHost = ldapConfSourceId, upsertUserLdapData = concat ldapData }
               -- whenIsLeft decodedErr $ addMessageI Error
-              return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
+              return . Just . singleton . (AuthSourceIdLdap ldapConfSourceId,) . Lazy.decodeUtf8 $ encodePretty ldapData
+              -- return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
 
   mbData <- formResultMaybe presult procFormPerson
 
diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs
index 9f2580333..04db439e6 100644
--- a/src/Ldap/Client/Instances.hs
+++ b/src/Ldap/Client/Instances.hs
@@ -19,6 +19,8 @@ import Utils.PathPiece (derivePathPiece)
 
 import Ldap.Client
 
+import Network.HTTP.Types.Method.Instances () -- for FromJSON instance for ByteString
+
 
 deriving instance Ord Attr
 deriving instance Ord Dn
@@ -54,4 +56,6 @@ derivePersistField "Password"
 derivePersistField "Scope"
 
 deriveJSON defaultOptions ''Attr
+deriveJSON defaultOptions ''Dn
 deriveJSON defaultOptions ''Scope
+deriveJSON defaultOptions ''SearchEntry
diff --git a/templates/admin/external-user.hamlet b/templates/admin/external-user.hamlet
index 7016383a8..44f4b5af2 100644
--- a/templates/admin/external-user.hamlet
+++ b/templates/admin/external-user.hamlet
@@ -22,16 +22,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
               LDAP host: #
               #{ldapHost}
         
      
-          
      
-            $forall (k,(numv,vUtf8,vLatin1)) <- responses
-              
      
-                #{k}
-                $if 1 < numv
-                  \ (#{show numv})
-              
      
-                UTF8:  #{vUtf8}
-                —
-                Latin: #{vLatin1}
+          
      +            #{responses}
+$#          
      
+$#            $forall (k,(numv,vUtf8,vLatin1)) <- responses
+$#              
      
+$#                #{k}
+$#                $if 1 < numv
+$#                  \ (#{show numv})
+$#              
      
+$#                UTF8:  #{vUtf8}
+$#                —
+$#                Latin: #{vLatin1}
 
 
      
   
      

From 98562727341fd860f5434e8b6481fbf1e5b948c6 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 11 Mar 2024 14:23:35 +0100
Subject: [PATCH 145/178] chore(login): do not login via modal

---
 src/Foundation/Navigation.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index 7a38e0459..a52cdbfb6 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -560,7 +560,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               { navLabel       = MsgMenuLogin
               , navRoute       = AuthR LoginR
               , navAccess'     = NavAccessHandler $ is _Nothing <$> maybeAuthId
-              , navType        = NavTypeLink { navModal = True }
+              , navType        = NavTypeLink { navModal = False }
               , navQuick'      = mempty
               , navForceActive = False
               }

From 05acba8cbeaa256494bfcd3899f3fb56335e69a2 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 11 Mar 2024 14:30:44 +0100
Subject: [PATCH 146/178] chore(foundation): ditch redirectToReferrer in favour
 of SSOut

---
 src/Foundation/Instances.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index e4d81cf88..8321894f8 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -134,7 +134,7 @@ instance YesodAuth UniWorX where
     -- Where to send a user after logout
     logoutDest _ = NewsR
     -- Override the above two destinations when a Referer: header is present
-    redirectToReferer _ = True
+    redirectToReferer _ = False
 
     loginHandler = do
       plugins <- getsYesod authPlugins

From 72938e41bac28d919379b91c7b6aa822eeb86aea Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 11 Mar 2024 15:07:50 +0100
Subject: [PATCH 147/178] chore: fix merge oopsie

---
 src/Settings.hs | 7 +------
 1 file changed, 1 insertion(+), 6 deletions(-)

diff --git a/src/Settings.hs b/src/Settings.hs
index 650ed85f4..1894d0f03 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -452,14 +452,9 @@ data AppSettings = AppSettings
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
-<<<<<<< HEAD
-    , appUserAuthConf           :: UserAuthConf -- TODO: add SSO option for user-auth config
-=======
+    , appUserAuthConf           :: UserAuthConf
     , appSingleSignOn           :: Bool
     -- ^ Enable OIDC single sign-on
-    , appLdapConf               :: Maybe (PointedList LdapConf)
-    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
->>>>>>> 139-single-sign-on-sso-routing-anpassen
     , appLmsConf                :: LmsConf
     -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) -- TODO, TODISCUSS: reimplement as user-auth source?
     , appAvsConf                :: Maybe AvsConf

From 5662a2d1f1fb7445e2e7d78aac6c0789ee42c954 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 11 Mar 2024 15:09:33 +0100
Subject: [PATCH 148/178] chore: fix merge oopsie contd

---
 src/Settings.hs | 7 -------
 1 file changed, 7 deletions(-)

diff --git a/src/Settings.hs b/src/Settings.hs
index 1894d0f03..1762c46fd 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -626,7 +626,6 @@ instance FromJSON AppSettings where
         appWebpackEntrypoints     <- o .: "webpack-manifest"
         appDatabaseConf           <- o .: "database"
         appAutoDbMigrate          <- o .: "auto-db-migrate"
-<<<<<<< HEAD
         -- TODO: reintroduce non-emptyness check for ldap hosts
         -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
         --       Ldap.Tls host _ -> not $ null host
@@ -635,13 +634,7 @@ instance FromJSON AppSettings where
         appUserAuthConf           <- o .: "user-auth"
         -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
         appLdapPoolConf           <- o .:? "ldap-pool"
-=======
         appSingleSignOn           <- o .: "single-sign-on"
-        let nonEmptyHost LdapConf{..} = case ldapHost of
-              Ldap.Tls host _ -> not $ null host
-              Ldap.Plain host -> not $ null host
-        appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
->>>>>>> 139-single-sign-on-sso-routing-anpassen
         appLmsConf                <- o .: "lms-direct"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
         appLprConf                <- o .: "lpr"

From 07dd91665c9151f99602dadbefd3f8173f08b1d7 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 11 Mar 2024 15:20:24 +0100
Subject: [PATCH 149/178] chore: fix auth plugin refs

---
 src/Foundation/Instances.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index 2bef8bec5..39b8ee163 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -23,7 +23,6 @@ import qualified Yesod.Core.Unsafe as Unsafe
 import qualified Yesod.Auth.Message as Auth
 
 import Utils.Form
-import Auth.OAuth2 (apAzure, apAzureMock)
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
@@ -142,7 +141,7 @@ instance YesodAuth UniWorX where
       AppSettings{..} <- getsYesod appSettings'
 
       when appSingleSignOn $ do
-        let plugin = P.head $ P.filter ((`elem` [mockPluginName, azurePluginName]) . apName) plugins
+        let plugin = P.head $ P.filter ((`elem` [apAzureMock, apAzure]) . apName) plugins
             pieces = case oauth2Url (apName plugin) of
                       PluginR _ p -> p
                       _ -> error "Unexpected OAuth2 AuthRoute"

From 843e6dbba2f9177754454eecd58ae89bdbb85ba3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 12 Mar 2024 18:09:18 +0100
Subject: [PATCH 150/178] chore(migration): add oauth2 migration

---
 src/Model/Migration/Definitions.hs | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index b41b8f61b..543f4121c 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -49,6 +49,7 @@ import qualified Data.Time.Zones as TZ
 data ManualMigration
   = Migration20230524QualificationUserBlock
   | Migration20230703LmsUserStatus
+  | Migration20240312OAuth2
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -177,6 +178,23 @@ customMigrations = mapF $ \case
         ;  
       |]
 
+  Migration20240312OAuth2 -> whenM (columnExists "user" "ldap_primary_key") $ do
+    [executeQQ|
+      ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL;
+    |]
+    let getPWHashes = [queryQQ| SELECT "id", "authentication"->'pw-hash' FROM "user" WHERE "authentication"->'pw-hash' IS NOT NULL; |]
+        migratePWHash [ fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (pwHash :: Text) ] = [executeQQ| UPDATE "user" SET "password_hash" = #{pwHash} WHERE "id" = #{uid}; |]
+        migratePWHash _ = error "otherwise case reached!" -- TODO: return ()
+     in runConduit $ getPWHashes .| C.mapM_ migratePWHash
+    [executeQQ|
+      ALTER TABLE "user" DROP COLUMN "authentication";
+    |]
+
+    [executeQQ|
+      ALTER TABLE "user" RENAME COLUMN "last_ldap_synchronisation" TO "password_hash";
+      ALTER TABLE "user" DROP COLUMN "ldap_primary_key";
+    |]
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

From 770c2f3182cd6633c656c909e162d9f182d63983 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 13 Mar 2024 10:20:10 +0100
Subject: [PATCH 151/178] chore(migration): fix oauth2 migration

---
 src/Model/Migration/Definitions.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 543f4121c..063bc985c 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -178,13 +178,13 @@ customMigrations = mapF $ \case
         ;  
       |]
 
-  Migration20240312OAuth2 -> whenM (columnExists "user" "ldap_primary_key") $ do
+  Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnExists "user" "ldap_primary_key" ]) $ do
     [executeQQ|
       ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL;
     |]
     let getPWHashes = [queryQQ| SELECT "id", "authentication"->'pw-hash' FROM "user" WHERE "authentication"->'pw-hash' IS NOT NULL; |]
         migratePWHash [ fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (pwHash :: Text) ] = [executeQQ| UPDATE "user" SET "password_hash" = #{pwHash} WHERE "id" = #{uid}; |]
-        migratePWHash _ = error "otherwise case reached!" -- TODO: return ()
+        migratePWHash _ = return ()
      in runConduit $ getPWHashes .| C.mapM_ migratePWHash
     [executeQQ|
       ALTER TABLE "user" DROP COLUMN "authentication";

From 6b82c26268edd516bb1ccc146626dcf7ff51c3d1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 13 Mar 2024 12:24:25 +0100
Subject: [PATCH 152/178] chore(migration): fix oauth2 migration contd

---
 src/Model/Migration/Definitions.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 063bc985c..662178fa1 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -178,7 +178,7 @@ customMigrations = mapF $ \case
         ;  
       |]
 
-  Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnExists "user" "ldap_primary_key" ]) $ do
+  Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnNotExists "user" "last_sync", columnExists "user" "ldap_primary_key" ]) $ do
     [executeQQ|
       ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL;
     |]
@@ -191,7 +191,7 @@ customMigrations = mapF $ \case
     |]
 
     [executeQQ|
-      ALTER TABLE "user" RENAME COLUMN "last_ldap_synchronisation" TO "password_hash";
+      ALTER TABLE "user" RENAME COLUMN "last_ldap_synchronisation" TO "last_sync";
       ALTER TABLE "user" DROP COLUMN "ldap_primary_key";
     |]
 

From acd6a3c11c75f85dd11422e4ad535d78512c06a8 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 12:42:10 +0100
Subject: [PATCH 153/178] chore: hlint

---
 src/Auth/OAuth2.hs           |  2 +-
 src/Foundation/Yesod/Auth.hs | 14 +++++++-------
 src/Settings.hs              |  2 +-
 3 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 272129052..fa1291407 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -120,7 +120,7 @@ azureMockServer port =
   let oa = OAuth2
             { oauth2ClientId = "42"
             , oauth2ClientSecret = Just "shhh"
-            , oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth")
+            , oauth2AuthorizeEndpoint = fromString (mockServerURL <> "/auth")
               `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
                           , ("response_type", "code id_token")
                           , ("nonce", "Foo") -- TODO generate meaningful value
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 94573e8fd..72f9cda84 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -51,7 +51,7 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
              -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
   $logErrorS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
-  setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds)
+  setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds)
   sess <- getSession
   $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
 
@@ -210,12 +210,12 @@ fetchUserData Creds{..} = do
           UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
     externalUserUser <- if
       | UpsertUserDataAzure{..} <- res
-      , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> \(t,bs) -> (t, filter (not . ByteString.null) bs)
-      , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
+      , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> second (filter (not . ByteString.null))
+      , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
         -> return $ CI.mk azureUserPrincipalName'
       | UpsertUserDataLdap{..} <- res
-      , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> \(t,bs) -> (t, filter (not . ByteString.null) bs)
-      , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
+      , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> second (filter (not . ByteString.null))
+      , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
         -> return $ CI.mk ldapPrimaryKey'
       | otherwise
         -> throwM DecodeUserInvalidIdent
@@ -291,11 +291,11 @@ decodeUser :: ( MonadThrow m
 decodeUser now UserDefaultConf{..} upsertData = do
     userIdent <- if
       | Just azureData <- mbAzureData
-      , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
+      , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
       , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
         -> return $ CI.mk azureUserPrincipalName''
       | Just ldapData <- mbLdapData
-      , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
+      , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
       , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
         -> return $ CI.mk ldapPrimaryKey''
       | otherwise
diff --git a/src/Settings.hs b/src/Settings.hs
index 1762c46fd..773071a5e 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -140,7 +140,7 @@ instance FromJSON PWHashConf where
 data AuthSourceConf = AuthSourceConfLdap LdapConf | AuthSourceConfAzureAdV2 AzureConf
   deriving (Show)
 
-data UserAuthConf =
+newtype UserAuthConf =
       UserAuthConfSingleSource -- ^ use only one specific source
       { userAuthConfSingleSource :: AuthSourceConf
       }

From 560d1adf5f398ef03b0367a8b02f007e93b921c0 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 12:47:04 +0100
Subject: [PATCH 154/178] chore(sso): disable sso by default (i.e. for develop)

---
 config/settings.yml | 2 +-
 src/Settings.hs     | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 787a584c3..cc35b1df9 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -149,7 +149,7 @@ user-auth:
     #   timeout:        "_env:LDAPTIMEOUT:5"
     #   search-timeout: "_env:LDAPSEARCHTIME:5"
 
-single-sign-on: "_env:OIDC_SSO:true"
+single-sign-on: "_env:OIDC_SSO:false"
 
 # TODO: generalize for arbitrary auth protocols
 # TODO: maybe use separate pools for external databases?
diff --git a/src/Settings.hs b/src/Settings.hs
index 773071a5e..fdf67357c 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -634,7 +634,7 @@ instance FromJSON AppSettings where
         appUserAuthConf           <- o .: "user-auth"
         -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
         appLdapPoolConf           <- o .:? "ldap-pool"
-        appSingleSignOn           <- o .: "single-sign-on"
+        appSingleSignOn           <- o .:? "single-sign-on" .!= False
         appLmsConf                <- o .: "lms-direct"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
         appLprConf                <- o .: "lpr"

From c4501f1d08026fd2c6da5f80f4972f0fd79498fe Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 13:06:58 +0100
Subject: [PATCH 155/178] chore: hlint

---
 src/Foundation/Yesod/Auth.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 72f9cda84..27a72425b 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -320,7 +320,7 @@ decodeUser now UserDefaultConf{..} upsertData = do
           = ( ldapData `decodeLdap` ldapUserSurname
             , ldapData `decodeLdap` ldapUserFirstName
             , ldapData `decodeLdap` ldapUserDisplayName
-            , ldapData `decodeLdap` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
+            , ldapData `decodeLdap` Ldap.Attr "mail" -- TODO: use ldapUserEmail?
             , ldapData `decodeLdap` ldapUserTelephone
             , ldapData `decodeLdap` ldapUserMobile
             , ldapData `decodeLdap` ldapUserFraportPersonalnummer
@@ -388,9 +388,9 @@ decodeUser now UserDefaultConf{..} upsertData = do
 
   where
     mbAzureData :: Maybe (Map Text [ByteString])
-    mbAzureData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
+    mbAzureData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
     mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
-    mbLdapData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
+    mbLdapData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
 
     -- just returns Nothing on error, pure
     decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text

From d44b903b3e9e9b5140726673ca91445066dd8c09 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 13:07:22 +0100
Subject: [PATCH 156/178] chore: fix tests

---
 test/Handler/Utils/SubmissionSpec.hs |  1 -
 test/Model/TypesSpec.hs              | 19 -------------------
 test/ModelSpec.hs                    | 25 ++++++++++++-------------
 test/User.hs                         |  5 ++---
 4 files changed, 14 insertions(+), 36 deletions(-)

diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs
index ed50724ba..4a16c559d 100644
--- a/test/Handler/Utils/SubmissionSpec.hs
+++ b/test/Handler/Utils/SubmissionSpec.hs
@@ -51,7 +51,6 @@ makeUsers (fromIntegral -> n) = do
     let baseid = "user." <> tshow i
         u' = u { userIdent          = CI.mk   baseid 
                , userEmail          = CI.mk $ baseid <> "@example.com"
-               , userLdapPrimaryKey = Just  $ baseid <> ".ldap"
                }
     return u'
   uids <- insertMany users
diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index fe9eb7325..b8b0eca50 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -10,7 +10,6 @@ module Model.TypesSpec
 
 import TestImport
 import TestInstances ()
-import Settings
 
 import Utils (guardOn)
 
@@ -21,7 +20,6 @@ import qualified Data.Aeson.Types as Aeson
 import Model.Types.LanguagesSpec ()
 
 import System.IO.Unsafe
-import Yesod.Auth.Util.PasswordStore
 
 import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)
 
@@ -217,21 +215,6 @@ instance Arbitrary Value where
       arbitrary' = scale (`div` 2) arbitrary
   shrink = genericShrink
 
-instance Arbitrary AuthenticationMode where
-  arbitrary = oneof
-    [ pure AuthLDAP
-    , do
-        pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
-        let
-          PWHashConf{..} = appAuthPWHash compileTimeAppSettings
-          authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
-        return $ AuthPWHash{..}
-    ]
-
-  shrink AuthLDAP = []
-  shrink AuthNoLogin = []
-  shrink (AuthPWHash _) = [AuthLDAP]
-
 instance Arbitrary LecturerType where
   arbitrary = genericArbitrary
   shrink = genericShrink
@@ -462,8 +445,6 @@ spec = do
       [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @CorrectorState)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-    lawsCheckHspec (Proxy @AuthenticationMode)
-      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @Value)
       [ persistFieldLaws ]
     lawsCheckHspec (Proxy @Scientific)
diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs
index 729f1a769..7fb5c4bc9 100644
--- a/test/ModelSpec.hs
+++ b/test/ModelSpec.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,7 +9,7 @@ module ModelSpec where
 
 import TestImport
 
-import Settings (getTimeLocale', VerpMode(..))
+import Settings
 
 import Model.TypesSpec ()
 import MailSpec ()
@@ -34,9 +34,10 @@ import qualified Data.CryptoID.Class.ImplicitNamespace as Implicit
 import qualified Data.CryptoID.Class as Explicit
 import Data.Binary.SerializationLength
 
-import Control.Monad.Catch.Pure (Catch, runCatch)
+import System.IO.Unsafe
+import Yesod.Auth.Util.PasswordStore
 
-import System.IO.Unsafe (unsafePerformIO)
+import Control.Monad.Catch.Pure (Catch, runCatch)
 
 import Data.Universe
 
@@ -102,7 +103,12 @@ instance Arbitrary User where
       [ getPrintableString <$> arbitrary
       , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
       ]
-    userAuthentication <- arbitrary
+    userPasswordHash <-
+      let genPwd = do
+            pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
+            let PWHashConf{..} = appAuthPWHash compileTimeAppSettings
+            return . unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
+       in oneof [ pure Nothing, Just <$> genPwd ]
     userLastAuthentication <- arbitrary
     userTokensIssuedAfter <- arbitrary
     userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
@@ -146,14 +152,7 @@ instance Arbitrary User where
     userExamOfficeGetLabels <- arbitrary
 
     userCreated <- arbitrary
-    userLastLdapSynchronisation <- arbitrary
-    userLdapPrimaryKey <- oneof
-      [ pure Nothing
-      , fmap Just $ pack <$> oneof
-        [ getPrintableString <$> arbitrary
-        , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
-        ]
-      ]
+    userLastSync <- arbitrary
 
     return User{..}
   shrink = genericShrink
diff --git a/test/User.hs b/test/User.hs
index 239488fff..c3fba1640 100644
--- a/test/User.hs
+++ b/test/User.hs
@@ -21,8 +21,9 @@ fakeUser adjUser = adjUser User{..}
     UserDefaultConf{..} = appUserDefaults compileTimeAppSettings
     
     userMatrikelnummer = Nothing
-    userAuthentication = AuthLDAP
+    userPasswordHash = Nothing
     userLastAuthentication = Nothing
+    userLastSync = Nothing
     userTokensIssuedAfter = Nothing
     userIdent = "dummy@example.invalid"
     userEmail = "dummy@example.invalid"
@@ -48,8 +49,6 @@ fakeUser adjUser = adjUser User{..}
     userShowSex = userDefaultShowSex
     userNotificationSettings = def
     userCreated = unsafePerformIO getCurrentTime
-    userLastLdapSynchronisation = Nothing
-    userLdapPrimaryKey = Nothing
     userMobile = Nothing 
     userTelephone = Nothing     
     userCompanyPersonalNumber = Nothing 

From f3da2ac6300233901019cbaf90e5f747265c5264 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 14:07:17 +0100
Subject: [PATCH 157/178] chore(sso): add bare auto-sign-out setting

---
 config/settings.yml | 4 ++++
 src/Settings.hs     | 4 ++++
 2 files changed, 8 insertions(+)

diff --git a/config/settings.yml b/config/settings.yml
index cc35b1df9..ed8743679 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -151,6 +151,10 @@ user-auth:
 
 single-sign-on: "_env:OIDC_SSO:false"
 
+# Automatically redirect to SSO route when not signed on
+# Note: This will force authentication, thus the site will be inaccessible without external credentials. Only use this option when it is ensured that every user that should be able to access the site has valid external credentials!
+auto-sign-on: "_env:AUTO_SIGN_ON:false"
+
 # TODO: generalize for arbitrary auth protocols
 # TODO: maybe use separate pools for external databases?
 ldap-pool:
diff --git a/src/Settings.hs b/src/Settings.hs
index fdf67357c..d94267891 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -455,6 +455,9 @@ data AppSettings = AppSettings
     , appUserAuthConf           :: UserAuthConf
     , appSingleSignOn           :: Bool
     -- ^ Enable OIDC single sign-on
+    , appAutoSignOn             :: Bool
+    -- ^ Automatically redirect to SSO route when not signed on
+    -- ^ Note: This will force authentication, thus the site will be inaccessible without external credentials. Only use this option when it is ensured that every user that should be able to access the site has valid external credentials!
     , appLmsConf                :: LmsConf
     -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) -- TODO, TODISCUSS: reimplement as user-auth source?
     , appAvsConf                :: Maybe AvsConf
@@ -635,6 +638,7 @@ instance FromJSON AppSettings where
         -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
         appLdapPoolConf           <- o .:? "ldap-pool"
         appSingleSignOn           <- o .:? "single-sign-on" .!= False
+        appAutoSignOn             <- o .:? "auto-sign-on" .!= False
         appLmsConf                <- o .: "lms-direct"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
         appLprConf                <- o .: "lpr"

From 2aa64f7360ec9fa66a2be1868ddcc7aa8abea71d Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 19:20:37 +0100
Subject: [PATCH 158/178] feat(sso): redirect to login when auto-sign-on is
 enabled and user is not authenticated

---
 src/Foundation/SiteLayout.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs
index 46d3f9272..3275485a2 100644
--- a/src/Foundation/SiteLayout.hs
+++ b/src/Foundation/SiteLayout.hs
@@ -156,6 +156,10 @@ siteLayout' overrideHeading widget = do
   --             isParent r = r == (fst parents)
 
   isAuth <- isJust <$> maybeAuthId
+
+  when (appAutoSignOn && not isAuth) $ do
+    $logDebugS "AutoSignOn" "AutoSignOn is enabled in AppSettings and user is not authenticated"
+    redirect $ AuthR LoginR
   
   now <- liftIO getCurrentTime
 

From 85dc1fa0b5de88170293ab678c1990828bd05afd Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 19:26:16 +0100
Subject: [PATCH 159/178] chore: depromote debug logErrorS calls

---
 src/Application.hs           | 2 +-
 src/Auth/OAuth2.hs           | 4 ++--
 src/Foundation/Yesod/Auth.hs | 6 +-----
 src/Handler/SingleSignOut.hs | 4 ++--
 4 files changed, 6 insertions(+), 10 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 7a53057e7..bc1ea2bec 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -672,7 +672,7 @@ appMain = runResourceT $ do
     foundation <- makeFoundation settings
 
     runAppLoggingT foundation $ do
-      $logErrorS "AppSettings" $ tshow settings
+      $logDebugS "AppSettings" $ tshow settings
 
       $logInfoS "setup" "Job-Handling"
       handleJobs foundation
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index fa1291407..97495c1d7 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -212,7 +212,7 @@ refreshOAuth2Token (_, rToken) url secure
         clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET"
         return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), scopeParam " " ["openid","profile"," offline_access"]] -- TODO read from config
       else return $ scopeParam " " ["openid","profile","offline_access"] : body -- TODO read from config
-    $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
+    $logDebugS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
     eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
     case eResult of
       Left x -> throwE $ UserDataJSONException x
@@ -241,6 +241,6 @@ singleSignOut mRedirect = do
       endpoint = case mRedirect of
         Just r -> base <> "?post_logout_redirect_uri=" <> r
         Nothing -> base
-  $logErrorS "\n\27[31mSSO\27[0m" endpoint 
+  $logDebugS "\n\27[31mSSO\27[0m" endpoint 
   redirect endpoint
 
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 27a72425b..c15240171 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -50,14 +50,10 @@ authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
              => Creds UniWorX
              -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logErrorS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
+  $logDebugS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m"
   setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds)
-  sess <- getSession
-  $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
 
   now <- liftIO getCurrentTime
-  userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only
-  $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only
 
   let
     uAuth = UniqueAuthentication $ CI.mk credsIdent
diff --git a/src/Handler/SingleSignOut.hs b/src/Handler/SingleSignOut.hs
index 8b89a19d0..ea057b4f0 100644
--- a/src/Handler/SingleSignOut.hs
+++ b/src/Handler/SingleSignOut.hs
@@ -14,7 +14,7 @@ import qualified Network.Wai as W
 
 getSOutR :: Handler Html
 getSOutR = do
-  $logErrorS "\27[31mSOut\27[0m" "Redirect to LogoutR"
+  $logDebugS "\27[31mSOut\27[0m" "Redirect to LogoutR"
   redirect $ AuthR LogoutR
 
 getSSOutR :: Handler Html
@@ -26,6 +26,6 @@ getSSOutR = do
         _ -> error "approt implementation changed"
       url = decodeUtf8 . urlEncode True . encodeUtf8 $ root <> "/" <> redir
   AppSettings{..} <- getsYesod appSettings'
-  $logErrorS "\27[31mSSOut\27[0m" "Redirect to auth server"
+  $logDebugS "\27[31mSSOut\27[0m" "Redirect to auth server"
   if appSingleSignOn then singleSignOut (Just url) else redirect (AuthR LogoutR)
 

From 6cd1d829b639cf027b73aec34286c6489974a4c4 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 21:59:15 +0100
Subject: [PATCH 160/178] chore(nix): fix backend build target

---
 nix/uniworx/backend.nix | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/nix/uniworx/backend.nix b/nix/uniworx/backend.nix
index 03fdb8431..3cc0bcd19 100644
--- a/nix/uniworx/backend.nix
+++ b/nix/uniworx/backend.nix
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Steffen Jost 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,7 @@
 with prev.lib;
 
 let
-  haskellInputs = ["encoding" "memcached-binary" "conduit-resumablesink" "HaskellNet-SSL" "ldap-client" "serversession" "xss-sanitize" "colonnade" "minio-hs" "cryptoids" "zip-stream" "yesod" "cryptonite" "esqueleto"];
+  haskellInputs = ["encoding" "memcached-binary" "conduit-resumablesink" "HaskellNet-SSL" "ldap-client" "serversession" "xss-sanitize" "colonnade" "minio-hs" "cryptoids" "zip-stream" "yesod" "yesod-auth-oauth2" "cryptonite" "esqueleto"];
 in {
   uniworx = final.haskell-nix.stackProject {
     src = prev.stdenv.mkDerivation {
@@ -53,6 +53,7 @@ in {
           yesod-persistent.src = "${inputs.yesod}/yesod-persistent";
           yesod-form.src = "${inputs.yesod}/yesod-form";
           yesod-auth.src = "${inputs.yesod}/yesod-auth";
+          yesod-auth-oauth2.src = inputs.yesod-auth-oauth2;
           yesod-test.src = "${inputs.yesod}/yesod-test";
           cryptonite.src = inputs.cryptonite;
           esqueleto.src = inputs.esqueleto;

From 1fc43a8727c2b42f32f4c51fe1be4058ae4fba0c Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 14 Mar 2024 22:14:53 +0100
Subject: [PATCH 161/178] chore: update flake

---
 flake.lock       | 18 ++++++++++++++++++
 flake.nix        |  8 ++++++++
 stack-flake.yaml |  3 ++-
 3 files changed, 28 insertions(+), 1 deletion(-)

diff --git a/flake.lock b/flake.lock
index 427561469..4156b15fa 100644
--- a/flake.lock
+++ b/flake.lock
@@ -516,6 +516,7 @@
         "serversession": "serversession",
         "xss-sanitize": "xss-sanitize",
         "yesod": "yesod",
+        "yesod-auth-oauth2": "yesod-auth-oauth2",
         "zip-stream": "zip-stream"
       }
     },
@@ -601,6 +602,23 @@
         "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
       }
     },
+    "yesod-auth-oauth2": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1698839053,
+        "narHash": "sha256-SV/Q++AStrVOzQFuugibywiRKT48lUE9xsZ1cQrbGJY=",
+        "owner": "freckle",
+        "repo": "yesod-auth-oauth2",
+        "rev": "11948a65c405f1a99ccb327d328d416e492542a1",
+        "type": "github"
+      },
+      "original": {
+        "owner": "freckle",
+        "ref": "11948a65c405f1a99ccb327d328d416e492542a1",
+        "repo": "yesod-auth-oauth2",
+        "type": "github"
+      }
+    },
     "zip-stream": {
       "flake": false,
       "locked": {
diff --git a/flake.nix b/flake.nix
index 2ecc482e0..b7b2ac007 100644
--- a/flake.nix
+++ b/flake.nix
@@ -84,6 +84,14 @@
       url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git?ref=uni2work";
       flake = false;
     };
+
+    yesod-auth-oauth2 = {
+      type  = "github";
+      owner = "freckle";
+      repo  = "yesod-auth-oauth2";
+      ref   = "11948a65c405f1a99ccb327d328d416e492542a1";
+      flake = false;
+    };
   };
 
   outputs = inputs@{ self, nixpkgs, nixpkgs-recent, flake-utils, haskell-nix, ... }: flake-utils.lib.eachSystem ["x86_64-linux"]
diff --git a/stack-flake.yaml b/stack-flake.yaml
index 09e2dd321..3e41a3f23 100644
--- a/stack-flake.yaml
+++ b/stack-flake.yaml
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,6 +45,7 @@ extra-deps:
   - @yesod@/yesod-auth
   - @yesod@/yesod-test
   - @yesod@/yesod
+  - @yesod-auth-oauth2@
   - @cryptonite@
   - @esqueleto@
   

From 4db44733ca3e423fa3f5625189ffe7b7f83a635f Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 15 Mar 2024 10:12:33 +0100
Subject: [PATCH 162/178] chore: fix haskell inputs

---
 flake.lock | 98 ++++++++++++++++++++++--------------------------------
 flake.nix  | 36 ++++++++------------
 2 files changed, 54 insertions(+), 80 deletions(-)

diff --git a/flake.lock b/flake.lock
index 4156b15fa..149583a7c 100644
--- a/flake.lock
+++ b/flake.lock
@@ -25,12 +25,12 @@
         "rev": "40393c938111ac78232dc2c7eec5edb4a22d03e8",
         "revCount": 62,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git"
+        "url": "https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git"
+        "url": "https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git"
       }
     },
     "cabal-32": {
@@ -92,12 +92,12 @@
         "rev": "f8170266ab25b533576e96715bedffc5aa4f19fa",
         "revCount": 153,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git"
+        "url": "https://gitlab.uniworx.de/haskell/colonnade.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git"
+        "url": "https://gitlab.uniworx.de/haskell/colonnade.git"
       }
     },
     "conduit-resumablesink": {
@@ -109,12 +109,12 @@
         "rev": "cbea6159c2975d42f948525e03e12fc390da53c5",
         "revCount": 10,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git"
+        "url": "https://gitlab.uniworx.de/haskell/conduit-resumablesink.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git"
+        "url": "https://gitlab.uniworx.de/haskell/conduit-resumablesink.git"
       }
     },
     "cryptoids": {
@@ -126,29 +126,29 @@
         "rev": "130b0dcbf2b09ccdf387b50262f1efbbbf1819e3",
         "revCount": 44,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git"
+        "url": "https://gitlab.uniworx.de/haskell/cryptoids.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git"
+        "url": "https://gitlab.uniworx.de/haskell/cryptoids.git"
       }
     },
     "cryptonite": {
       "flake": false,
       "locked": {
-        "lastModified": 1624444174,
-        "narHash": "sha256-sDMA4ej1NIModAt7PQvcgIknI3KwfzcAp9YQUSe4CWw=",
+        "lastModified": 1704764911,
+        "narHash": "sha256-VuEWT2Bd4aSJyRcXpB+lsGDqxrTHB/uRvILzYWLNfxk=",
         "ref": "uni2work",
-        "rev": "71a630edaf5f22c464e24fac8d9d310f4055ea1f",
-        "revCount": 1202,
+        "rev": "f78fca2504bb767d632a3bac8dbbc23367eff0e9",
+        "revCount": 1220,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git"
+        "url": "https://gitlab.uniworx.de/haskell/cryptonite.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git"
+        "url": "https://gitlab.uniworx.de/haskell/cryptonite.git"
       }
     },
     "encoding": {
@@ -160,12 +160,12 @@
         "rev": "22fc3bb14841d8d50997aa47f1be3852e666f787",
         "revCount": 162,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git"
+        "url": "https://gitlab.uniworx.de/haskell/encoding.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git"
+        "url": "https://gitlab.uniworx.de/haskell/encoding.git"
       }
     },
     "esqueleto": {
@@ -177,12 +177,12 @@
         "rev": "e18dd125c5ea26fa4e88bed079b61d8c1365ee37",
         "revCount": 708,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git"
+        "url": "https://gitlab.uniworx.de/haskell/esqueleto.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git"
+        "url": "https://gitlab.uniworx.de/haskell/esqueleto.git"
       }
     },
     "flake-utils": {
@@ -310,12 +310,12 @@
         "rev": "01afaf599ba6f8a9d804c269e91d3190b249d3f0",
         "revCount": 61,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git"
+        "url": "https://gitlab.uniworx.de/haskell/ldap-client.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git"
+        "url": "https://gitlab.uniworx.de/haskell/ldap-client.git"
       }
     },
     "memcached-binary": {
@@ -327,29 +327,29 @@
         "rev": "b7071df50bad3a251a544b984e4bf98fa09b8fae",
         "revCount": 28,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git"
+        "url": "https://gitlab.uniworx.de/haskell/memcached-binary.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git"
+        "url": "https://gitlab.uniworx.de/haskell/memcached-binary.git"
       }
     },
     "minio-hs": {
       "flake": false,
       "locked": {
-        "lastModified": 1597069863,
-        "narHash": "sha256-JmMajaLT4+zt+w2koDkaloFL8ugmrQBlcYKj+78qn9M=",
+        "lastModified": 1705548354,
+        "narHash": "sha256-wuJYScDu1hGlasE4rzUEi9ouvEiQYWcHF9jRngiQ3Z4=",
         "ref": "uni2work",
-        "rev": "42103ab247057c04c8ce7a83d9d4c160713a3df1",
-        "revCount": 197,
+        "rev": "fafc203e1bace1998264d1ce4340fb801e877b51",
+        "revCount": 223,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git"
+        "url": "https://gitlab.uniworx.de/haskell/minio-hs.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git"
+        "url": "https://gitlab.uniworx.de/haskell/minio-hs.git"
       }
     },
     "nix-tools": {
@@ -516,7 +516,6 @@
         "serversession": "serversession",
         "xss-sanitize": "xss-sanitize",
         "yesod": "yesod",
-        "yesod-auth-oauth2": "yesod-auth-oauth2",
         "zip-stream": "zip-stream"
       }
     },
@@ -529,12 +528,12 @@
         "rev": "b9d76def10da1260c7f6aa82bda32111f37a952b",
         "revCount": 174,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git"
+        "url": "https://gitlab.uniworx.de/haskell/serversession.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git"
+        "url": "https://gitlab.uniworx.de/haskell/serversession.git"
       }
     },
     "stackage": {
@@ -577,46 +576,29 @@
         "rev": "dc928c3a456074b8777603bea20e81937321777f",
         "revCount": 114,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git"
+        "url": "https://gitlab.uniworx.de/haskell/xss-sanitize.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git"
+        "url": "https://gitlab.uniworx.de/haskell/xss-sanitize.git"
       }
     },
     "yesod": {
       "flake": false,
       "locked": {
-        "lastModified": 1625061191,
-        "narHash": "sha256-K0X2MwUStChml1DlJ7t4yBMDwrMe6j/780nJtSy9Hss=",
+        "lastModified": 1705542497,
+        "narHash": "sha256-DYri6G3LeL3Gu11K0gAcUOxMwyKrLVkNnb5oTjHKRro=",
         "ref": "uni2work",
-        "rev": "a59f63e0336ee61f7a90b8778e9147305d3127bb",
-        "revCount": 5053,
+        "rev": "9f8d26371d4760f8985e7bbe00c3ac16be1301bc",
+        "revCount": 5208,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
+        "url": "https://gitlab.uniworx.de/haskell/yesod.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
-      }
-    },
-    "yesod-auth-oauth2": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1698839053,
-        "narHash": "sha256-SV/Q++AStrVOzQFuugibywiRKT48lUE9xsZ1cQrbGJY=",
-        "owner": "freckle",
-        "repo": "yesod-auth-oauth2",
-        "rev": "11948a65c405f1a99ccb327d328d416e492542a1",
-        "type": "github"
-      },
-      "original": {
-        "owner": "freckle",
-        "ref": "11948a65c405f1a99ccb327d328d416e492542a1",
-        "repo": "yesod-auth-oauth2",
-        "type": "github"
+        "url": "https://gitlab.uniworx.de/haskell/yesod.git"
       }
     },
     "zip-stream": {
@@ -628,12 +610,12 @@
         "rev": "843683d024f767de236f74d24a3348f69181a720",
         "revCount": 39,
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git"
+        "url": "https://gitlab.uniworx.de/haskell/zip-stream.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git"
+        "url": "https://gitlab.uniworx.de/haskell/zip-stream.git"
       }
     }
   },
diff --git a/flake.nix b/flake.nix
index b7b2ac007..3202c7087 100644
--- a/flake.nix
+++ b/flake.nix
@@ -29,67 +29,59 @@
     };
 
     encoding = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/encoding.git?ref=uni2work";
       flake = false;
     };
     memcached-binary = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/memcached-binary.git?ref=uni2work";
       flake = false;
     };
     conduit-resumablesink = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/conduit-resumablesink.git?ref=uni2work";
       flake = false;
     };
     HaskellNet-SSL = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git?ref=uni2work";
       flake = false;
     };
     ldap-client = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/ldap-client.git?ref=uni2work";
       flake = false;
     };
     serversession = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/serversession.git?ref=uni2work";
       flake = false;
     };
     xss-sanitize = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/xss-sanitize.git?ref=uni2work";
       flake = false;
     };
     colonnade = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/colonnade.git?ref=uni2work";
       flake = false;
     };
     minio-hs = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/minio-hs.git?ref=uni2work";
       flake = false;
     };
     cryptoids = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/cryptoids.git?ref=uni2work";
       flake = false;
     };
     zip-stream = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/zip-stream.git?ref=uni2work";
       flake = false;
     };
     yesod = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/yesod.git?ref=uni2work";
       flake = false;
     };
     cryptonite = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git?ref=uni2work";
+      url = "git+https://gitlab.uniworx.de/haskell/cryptonite.git?ref=uni2work";
       flake = false;
     };
     esqueleto = {
-      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git?ref=uni2work";
-      flake = false;
-    };
-
-    yesod-auth-oauth2 = {
-      type  = "github";
-      owner = "freckle";
-      repo  = "yesod-auth-oauth2";
-      ref   = "11948a65c405f1a99ccb327d328d416e492542a1";
+      url = "git+https://gitlab.uniworx.de/haskell/esqueleto.git?ref=uni2work";
       flake = false;
     };
   };

From a4eda814365afaec15f3d002ead6d99e4c200ebf Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Fri, 15 Mar 2024 10:40:07 +0100
Subject: [PATCH 163/178] chore: work on flakey oauth2 yesod plugin input for
 v0.7.2 specifically

---
 flake.lock      | 17 +++++++++++++++++
 flake.nix       |  5 +++++
 stack.yaml      |  6 +++---
 stack.yaml.lock | 18 +++++++-----------
 4 files changed, 32 insertions(+), 14 deletions(-)

diff --git a/flake.lock b/flake.lock
index 149583a7c..c5bd78ccf 100644
--- a/flake.lock
+++ b/flake.lock
@@ -516,6 +516,7 @@
         "serversession": "serversession",
         "xss-sanitize": "xss-sanitize",
         "yesod": "yesod",
+        "yesod-auth-oauth2": "yesod-auth-oauth2",
         "zip-stream": "zip-stream"
       }
     },
@@ -601,6 +602,22 @@
         "url": "https://gitlab.uniworx.de/haskell/yesod.git"
       }
     },
+    "yesod-auth-oauth2": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1709302944,
+        "narHash": "sha256-6YPPNMe5oc+58gfzMixmmkJ0htwCI5/KSpWcsUpFcto=",
+        "ref": "refs/heads/main",
+        "rev": "acb69f8da40b9c91b4020296ce105119e76fdf1d",
+        "revCount": 415,
+        "type": "git",
+        "url": "https://github.com/freckle/yesod-auth-oauth2.git?tag=v0.7.2.0"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://github.com/freckle/yesod-auth-oauth2.git?tag=v0.7.2.0"
+      }
+    },
     "zip-stream": {
       "flake": false,
       "locked": {
diff --git a/flake.nix b/flake.nix
index 3202c7087..64b18fbe2 100644
--- a/flake.nix
+++ b/flake.nix
@@ -84,6 +84,11 @@
       url = "git+https://gitlab.uniworx.de/haskell/esqueleto.git?ref=uni2work";
       flake = false;
     };
+
+    yesod-auth-oauth2 = {
+      url = "git+https://github.com/freckle/yesod-auth-oauth2.git?tag=v0.7.2.0";
+      flake = false;
+    };
   };
 
   outputs = inputs@{ self, nixpkgs, nixpkgs-recent, flake-utils, haskell-nix, ... }: flake-utils.lib.eachSystem ["x86_64-linux"]
diff --git a/stack.yaml b/stack.yaml
index e5b66c6db..9a8c947b4 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -88,9 +88,6 @@ extra-deps:
       - yesod-eventsource
       - yesod-websockets
 
-  - git: https://github.com/freckle/yesod-auth-oauth2
-    commit: 11948a65c405f1a99ccb327d328d416e492542a1
-
   - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
 
@@ -123,5 +120,8 @@ extra-deps:
   - saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198
   - persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601
 
+  - yesod-auth-oauth2-0.7.2.0@sha256:7203cdcde371093b0d74ffbcf974bbd385ef6da84225b25f990459914ab7aae3,3437
+
+
 resolver: lts-18.0
 allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index d6c9f21c4..07c5ec982 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -415,17 +415,6 @@ packages:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
     git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-websockets
-- completed:
-    commit: 11948a65c405f1a99ccb327d328d416e492542a1
-    git: https://github.com/freckle/yesod-auth-oauth2
-    name: yesod-auth-oauth2
-    pantry-tree:
-      sha256: a68ec51e1008c315dd15e81cc3ac1f4e2adfd3db623259395757ecae2787cef2
-      size: 4277
-    version: 0.7.1.3
-  original:
-    commit: 11948a65c405f1a99ccb327d328d416e492542a1
-    git: https://github.com/freckle/yesod-auth-oauth2
 - completed:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
     git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
@@ -546,6 +535,13 @@ packages:
       size: 1059
   original:
     hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601
+- completed:
+    hackage: yesod-auth-oauth2-0.7.2.0@sha256:7203cdcde371093b0d74ffbcf974bbd385ef6da84225b25f990459914ab7aae3,3437
+    pantry-tree:
+      sha256: 67fd933ca8d25705b39d9aaaadf6329d686b4b743374999996053243d6a33e68
+      size: 2425
+  original:
+    hackage: yesod-auth-oauth2-0.7.2.0@sha256:7203cdcde371093b0d74ffbcf974bbd385ef6da84225b25f990459914ab7aae3,3437
 snapshots:
 - completed:
     sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0

From dbfd3657a0b4d921c63796980d5cc273ffb3aac9 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 18 Mar 2024 12:50:59 +0100
Subject: [PATCH 164/178] chore(flake): remove redundant inputs

---
 flake.lock | 17 -----------------
 flake.nix  |  7 +------
 2 files changed, 1 insertion(+), 23 deletions(-)

diff --git a/flake.lock b/flake.lock
index c5bd78ccf..149583a7c 100644
--- a/flake.lock
+++ b/flake.lock
@@ -516,7 +516,6 @@
         "serversession": "serversession",
         "xss-sanitize": "xss-sanitize",
         "yesod": "yesod",
-        "yesod-auth-oauth2": "yesod-auth-oauth2",
         "zip-stream": "zip-stream"
       }
     },
@@ -602,22 +601,6 @@
         "url": "https://gitlab.uniworx.de/haskell/yesod.git"
       }
     },
-    "yesod-auth-oauth2": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1709302944,
-        "narHash": "sha256-6YPPNMe5oc+58gfzMixmmkJ0htwCI5/KSpWcsUpFcto=",
-        "ref": "refs/heads/main",
-        "rev": "acb69f8da40b9c91b4020296ce105119e76fdf1d",
-        "revCount": 415,
-        "type": "git",
-        "url": "https://github.com/freckle/yesod-auth-oauth2.git?tag=v0.7.2.0"
-      },
-      "original": {
-        "type": "git",
-        "url": "https://github.com/freckle/yesod-auth-oauth2.git?tag=v0.7.2.0"
-      }
-    },
     "zip-stream": {
       "flake": false,
       "locked": {
diff --git a/flake.nix b/flake.nix
index 64b18fbe2..70f4146ef 100644
--- a/flake.nix
+++ b/flake.nix
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -84,11 +84,6 @@
       url = "git+https://gitlab.uniworx.de/haskell/esqueleto.git?ref=uni2work";
       flake = false;
     };
-
-    yesod-auth-oauth2 = {
-      url = "git+https://github.com/freckle/yesod-auth-oauth2.git?tag=v0.7.2.0";
-      flake = false;
-    };
   };
 
   outputs = inputs@{ self, nixpkgs, nixpkgs-recent, flake-utils, haskell-nix, ... }: flake-utils.lib.eachSystem ["x86_64-linux"]

From 923166b592e6fb343a91cdffa549e5c3546cf9a4 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 18 Mar 2024 12:51:19 +0100
Subject: [PATCH 165/178] chore: update package.yaml

---
 package.yaml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/package.yaml b/package.yaml
index 809c0cb4b..4ca561014 100644
--- a/package.yaml
+++ b/package.yaml
@@ -127,6 +127,7 @@ dependencies:
   - mono-traversable
   - mono-traversable-keys
   - lens-aeson
+  - attoparsec-aeson
   - systemd
   - streaming-commons
   - unix

From 7e33d9e5de13ea344de351fa9b9c1ed81c5d3b91 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 18 Mar 2024 12:53:37 +0100
Subject: [PATCH 166/178] chore: update stack(-flake).yaml (fix fork urls, add
 inputs, revert to previous oauth2 lib)

---
 stack-flake.yaml |  7 +++++--
 stack.yaml       | 35 ++++++++++++++++++-----------------
 2 files changed, 23 insertions(+), 19 deletions(-)

diff --git a/stack-flake.yaml b/stack-flake.yaml
index 3e41a3f23..7618a4e36 100644
--- a/stack-flake.yaml
+++ b/stack-flake.yaml
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel 
+# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,7 +45,6 @@ extra-deps:
   - @yesod@/yesod-auth
   - @yesod@/yesod-test
   - @yesod@/yesod
-  - @yesod-auth-oauth2@
   - @cryptonite@
   - @esqueleto@
   
@@ -83,5 +82,9 @@ extra-deps:
 
   - servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755
 
+  - yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
+  - attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
+  - integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
+
 resolver: lts-18.0
 allow-newer: true
diff --git a/stack.yaml b/stack.yaml
index 9a8c947b4..2c7784d47 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -26,33 +26,33 @@ packages:
   - .
 
 extra-deps:
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
+  - git: https://gitlab.uniworx.de/haskell/encoding.git
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
+  - git: https://gitlab.uniworx.de/haskell/memcached-binary.git
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
+  - git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
   - git: https://github.com/jtdaugherty/HaskellNet.git
     commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
+  - git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
+  - git: https://gitlab.uniworx.de/haskell/ldap-client.git
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+  - git: https://gitlab.uniworx.de/haskell/serversession.git
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
     subdirs:
       - serversession
       - serversession-backend-acid-state
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
+  - git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
     commit: dc928c3a456074b8777603bea20e81937321777f
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
+  - git: https://gitlab.uniworx.de/haskell/colonnade.git
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
     subdirs:
       - colonnade
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
+  - git: https://gitlab.uniworx.de/haskell/minio-hs.git
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+  - git: https://gitlab.uniworx.de/haskell/cryptoids.git
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
     subdirs:
       - cryptoids-class
@@ -67,10 +67,10 @@ extra-deps:
       - gearhash
       - fastcdc
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
+  - git: https://gitlab.uniworx.de/haskell/zip-stream.git
     commit: 843683d024f767de236f74d24a3348f69181a720
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+  - git: https://gitlab.uniworx.de/haskell/yesod.git
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb
     subdirs:
       - yesod-core
@@ -88,10 +88,10 @@ extra-deps:
       - yesod-eventsource
       - yesod-websockets
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
+  - git: https://gitlab.uniworx.de/haskell/cryptonite.git
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
+  - git: https://gitlab.uniworx.de/haskell/esqueleto.git
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
 
   - classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
@@ -120,8 +120,9 @@ extra-deps:
   - saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198
   - persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601
 
-  - yesod-auth-oauth2-0.7.2.0@sha256:7203cdcde371093b0d74ffbcf974bbd385ef6da84225b25f990459914ab7aae3,3437
-
+  - yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
+  - attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
+  - integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
 
 resolver: lts-18.0
 allow-newer: true

From 8be3e2ea788d7a125b38b78d31fb9c932dcafb5e Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 18 Mar 2024 12:54:05 +0100
Subject: [PATCH 167/178] chore: use previous oauth2 lib

---
 src/Application.hs |  6 +++---
 src/Auth/OAuth2.hs | 10 +++++-----
 2 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index bc1ea2bec..271d09068 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -61,7 +61,7 @@ import Jobs
 
 import qualified Data.Text.Encoding as Text
 
-import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped)
+import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
 import Yesod.Auth.Util.PasswordStore
 
 import qualified Data.ByteString.Lazy as LBS
@@ -349,7 +349,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 #ifdef DEVELOPMENT
       oauth2Plugins <- liftIO $ sequence
         [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
-        , return $ oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] "42" "42" "shhh"
+        , return $ oauth2AzureADScoped ["openid", "profile", "offline_access"] "42" "shhh"
         ]
 #else
       let -- Auth Plugins
@@ -366,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do
             -> error "Tenant ID missing!"
         oauth2Plugins
           | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
-            -> singleton $ oauth2AzureADv2Scoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
+            -> singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
           | otherwise
             -> mempty
 #endif
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 97495c1d7..88bcff790 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -118,15 +118,15 @@ instance FromJSON UserID where
 azureMockServer :: YesodAuth m => String -> AuthPlugin m
 azureMockServer port =
   let oa = OAuth2
-            { oauth2ClientId = "42"
-            , oauth2ClientSecret = Just "shhh"
-            , oauth2AuthorizeEndpoint = fromString (mockServerURL <> "/auth")
+            { oauthClientId = "42"
+            , oauthClientSecret = Just "shhh"
+            , oauthOAuthorizeEndpoint = fromString (mockServerURL <> "/auth")
               `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
                           , ("response_type", "code id_token")
                           , ("nonce", "Foo") -- TODO generate meaningful value
                           ]
-            , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
-            , oauth2RedirectUri = Nothing
+            , oauthAccessTokenEndpoint = fromString $ mockServerURL <> "/token"
+            , oauthCallback = Nothing
             }
       mockServerURL = "http://localhost:" <> fromString port
       profileSrc = fromString $ mockServerURL <> "/users/me"

From 94d45c1f1707c2d71db2c68602cc6062f63ff9fc Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 18 Mar 2024 12:54:30 +0100
Subject: [PATCH 168/178] chore: update stack.yaml.lock

---
 stack.yaml.lock | 150 ++++++++++++++++++++++++++----------------------
 1 file changed, 82 insertions(+), 68 deletions(-)

diff --git a/stack.yaml.lock b/stack.yaml.lock
index 07c5ec982..366f7b609 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -6,7 +6,7 @@
 packages:
 - completed:
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
+    git: https://gitlab.uniworx.de/haskell/encoding.git
     name: encoding
     pantry-tree:
       sha256: fec12328951021bb4d9326ae0b35f0c459e65f28442366efd4366cd1e18abe19
@@ -14,10 +14,10 @@ packages:
     version: 0.8.2
   original:
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
+    git: https://gitlab.uniworx.de/haskell/encoding.git
 - completed:
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
+    git: https://gitlab.uniworx.de/haskell/memcached-binary.git
     name: memcached-binary
     pantry-tree:
       sha256: 0da0539b7b9a56d03a116dcd666bc1bbbef085659910420849484d1418aa0857
@@ -25,10 +25,10 @@ packages:
     version: 0.2.0
   original:
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
+    git: https://gitlab.uniworx.de/haskell/memcached-binary.git
 - completed:
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
+    git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
     name: conduit-resumablesink
     pantry-tree:
       sha256: 0cccf4684bbd84f81d2d3d53dd81c46cb103b5322f1d8e89e9b222211281e1b7
@@ -36,7 +36,7 @@ packages:
     version: '0.3'
   original:
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
+    git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
 - completed:
     commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
     git: https://github.com/jtdaugherty/HaskellNet.git
@@ -50,7 +50,7 @@ packages:
     git: https://github.com/jtdaugherty/HaskellNet.git
 - completed:
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
+    git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
     name: HaskellNet-SSL
     pantry-tree:
       sha256: 95dcec22fdb8af986e59f0f60aa76d4a48f34a546dca799bd571e1d183f773e0
@@ -58,10 +58,10 @@ packages:
     version: 0.3.4.1
   original:
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
+    git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
 - completed:
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
+    git: https://gitlab.uniworx.de/haskell/ldap-client.git
     name: ldap-client
     pantry-tree:
       sha256: 3fa8f102427b437b2baaec15cf884e88b47a1621b1c3fd4d8919f0263fde8656
@@ -69,10 +69,10 @@ packages:
     version: 0.4.0
   original:
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
+    git: https://gitlab.uniworx.de/haskell/ldap-client.git
 - completed:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     name: serversession
     pantry-tree:
       sha256: 83ac78a987399db3da62f84bbd335fead11aadebd57251d0688127fca984db23
@@ -81,11 +81,11 @@ packages:
     version: 1.0.2
   original:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     subdir: serversession
 - completed:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     name: serversession-backend-acid-state
     pantry-tree:
       sha256: 4804260c6245c12e1728c78dd33bf16e95b7f2b69b38b6900a4e65b1ef3e04b7
@@ -94,11 +94,11 @@ packages:
     version: 1.0.4
   original:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     subdir: serversession-backend-acid-state
 - completed:
     commit: dc928c3a456074b8777603bea20e81937321777f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
+    git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
     name: xss-sanitize
     pantry-tree:
       sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975
@@ -106,10 +106,10 @@ packages:
     version: 0.3.6
   original:
     commit: dc928c3a456074b8777603bea20e81937321777f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
+    git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
 - completed:
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
+    git: https://gitlab.uniworx.de/haskell/colonnade.git
     name: colonnade
     pantry-tree:
       sha256: 392393652cc0f354d351482557b9385c8e6122e706359b030373656565f2e045
@@ -118,11 +118,11 @@ packages:
     version: 1.2.0.2
   original:
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
+    git: https://gitlab.uniworx.de/haskell/colonnade.git
     subdir: colonnade
 - completed:
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
+    git: https://gitlab.uniworx.de/haskell/minio-hs.git
     name: minio-hs
     pantry-tree:
       sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
@@ -130,10 +130,10 @@ packages:
     version: 1.5.2
   original:
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
+    git: https://gitlab.uniworx.de/haskell/minio-hs.git
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: cryptoids-class
     pantry-tree:
       sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203
@@ -142,11 +142,11 @@ packages:
     version: 0.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: cryptoids-class
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: cryptoids-types
     pantry-tree:
       sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e
@@ -155,11 +155,11 @@ packages:
     version: 1.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: cryptoids-types
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: cryptoids
     pantry-tree:
       sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb
@@ -168,11 +168,11 @@ packages:
     version: 0.5.1.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: cryptoids
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: filepath-crypto
     pantry-tree:
       sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9
@@ -181,11 +181,11 @@ packages:
     version: 0.1.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: filepath-crypto
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: uuid-crypto
     pantry-tree:
       sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4
@@ -194,7 +194,7 @@ packages:
     version: 1.4.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: uuid-crypto
 - completed:
     commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d
@@ -224,7 +224,7 @@ packages:
     subdir: fastcdc
 - completed:
     commit: 843683d024f767de236f74d24a3348f69181a720
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
+    git: https://gitlab.uniworx.de/haskell/zip-stream.git
     name: zip-stream
     pantry-tree:
       sha256: 0da8bc38d73034962d2e2d1a7586b6dee848a629319fce9cbbf578348c61118c
@@ -232,10 +232,10 @@ packages:
     version: 0.2.0.1
   original:
     commit: 843683d024f767de236f74d24a3348f69181a720
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
+    git: https://gitlab.uniworx.de/haskell/zip-stream.git
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-core
     pantry-tree:
       sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a
@@ -244,11 +244,11 @@ packages:
     version: 1.6.20.2
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-core
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-static
     pantry-tree:
       sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06
@@ -257,11 +257,11 @@ packages:
     version: 1.6.1.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-static
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-persistent
     pantry-tree:
       sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c
@@ -270,11 +270,11 @@ packages:
     version: 1.6.0.7
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-persistent
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-newsfeed
     pantry-tree:
       sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099
@@ -283,11 +283,11 @@ packages:
     version: 1.7.0.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-newsfeed
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-form
     pantry-tree:
       sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f
@@ -296,11 +296,11 @@ packages:
     version: 1.7.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-form
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-form-multi
     pantry-tree:
       sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6
@@ -309,11 +309,11 @@ packages:
     version: 1.7.0.2
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-form-multi
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-auth
     pantry-tree:
       sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08
@@ -322,11 +322,11 @@ packages:
     version: 1.6.10.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-auth
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-auth-oauth
     pantry-tree:
       sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4
@@ -335,11 +335,11 @@ packages:
     version: 1.6.0.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-auth-oauth
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-sitemap
     pantry-tree:
       sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27
@@ -348,11 +348,11 @@ packages:
     version: 1.6.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-sitemap
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-test
     pantry-tree:
       sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1
@@ -361,11 +361,11 @@ packages:
     version: 1.6.12
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-test
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-bin
     pantry-tree:
       sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8
@@ -374,11 +374,11 @@ packages:
     version: 1.6.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-bin
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod
     pantry-tree:
       sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42
@@ -387,11 +387,11 @@ packages:
     version: 1.6.1.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-eventsource
     pantry-tree:
       sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2
@@ -400,11 +400,11 @@ packages:
     version: 1.6.0.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-eventsource
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-websockets
     pantry-tree:
       sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5
@@ -413,11 +413,11 @@ packages:
     version: 0.3.0.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-websockets
 - completed:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
+    git: https://gitlab.uniworx.de/haskell/cryptonite.git
     name: cryptonite
     pantry-tree:
       sha256: 19e49259fa5e3c257495d72b3c7c3c49537aeafd508c780c2430ddca2ef71a91
@@ -425,10 +425,10 @@ packages:
     version: '0.29'
   original:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
+    git: https://gitlab.uniworx.de/haskell/cryptonite.git
 - completed:
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
+    git: https://gitlab.uniworx.de/haskell/esqueleto.git
     name: esqueleto
     pantry-tree:
       sha256: 8a93dc98eb4529ff64aa5bcdaa3c00dcdf0378033ad675864e2b0fc3d869d947
@@ -436,7 +436,7 @@ packages:
     version: 3.5.4.0
   original:
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
+    git: https://gitlab.uniworx.de/haskell/esqueleto.git
 - completed:
     hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
     pantry-tree:
@@ -536,12 +536,26 @@ packages:
   original:
     hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601
 - completed:
-    hackage: yesod-auth-oauth2-0.7.2.0@sha256:7203cdcde371093b0d74ffbcf974bbd385ef6da84225b25f990459914ab7aae3,3437
+    hackage: yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
     pantry-tree:
-      sha256: 67fd933ca8d25705b39d9aaaadf6329d686b4b743374999996053243d6a33e68
-      size: 2425
+      sha256: 56094dc446a82f1c3abb1f7fa2a439855c5bbb7463c20a95d93673b27a90cbcc
+      size: 1919
   original:
-    hackage: yesod-auth-oauth2-0.7.2.0@sha256:7203cdcde371093b0d74ffbcf974bbd385ef6da84225b25f990459914ab7aae3,3437
+    hackage: yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
+- completed:
+    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
+    pantry-tree:
+      sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a
+      size: 114
+  original:
+    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
+- completed:
+    hackage: integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
+    pantry-tree:
+      sha256: 5684bd08f7edbadbff77d84075b37cdf41309bd8a0dc23bcea6ffbf4497adb7f
+      size: 509
+  original:
+    hackage: integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
 snapshots:
 - completed:
     sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0

From 9428bc05cc28808b190b21d3971a5baa8e86a81c Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Mon, 18 Mar 2024 15:28:02 +0100
Subject: [PATCH 169/178] chore: revert to previous flake inputs

---
 flake.lock              |  80 ++++++++++----------
 flake.nix               |  30 ++++----
 nix/uniworx/backend.nix |   5 +-
 package.yaml            |   1 -
 src/Application.hs      |   6 +-
 src/Auth/OAuth2.hs      |  10 +--
 stack-flake.yaml        |   4 -
 stack.yaml              |  37 +++++-----
 stack.yaml.lock         | 160 +++++++++++++++++++---------------------
 9 files changed, 158 insertions(+), 175 deletions(-)

diff --git a/flake.lock b/flake.lock
index 149583a7c..427561469 100644
--- a/flake.lock
+++ b/flake.lock
@@ -25,12 +25,12 @@
         "rev": "40393c938111ac78232dc2c7eec5edb4a22d03e8",
         "revCount": 62,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git"
       }
     },
     "cabal-32": {
@@ -92,12 +92,12 @@
         "rev": "f8170266ab25b533576e96715bedffc5aa4f19fa",
         "revCount": 153,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/colonnade.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/colonnade.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git"
       }
     },
     "conduit-resumablesink": {
@@ -109,12 +109,12 @@
         "rev": "cbea6159c2975d42f948525e03e12fc390da53c5",
         "revCount": 10,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/conduit-resumablesink.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/conduit-resumablesink.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git"
       }
     },
     "cryptoids": {
@@ -126,29 +126,29 @@
         "rev": "130b0dcbf2b09ccdf387b50262f1efbbbf1819e3",
         "revCount": 44,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptoids.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptoids.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git"
       }
     },
     "cryptonite": {
       "flake": false,
       "locked": {
-        "lastModified": 1704764911,
-        "narHash": "sha256-VuEWT2Bd4aSJyRcXpB+lsGDqxrTHB/uRvILzYWLNfxk=",
+        "lastModified": 1624444174,
+        "narHash": "sha256-sDMA4ej1NIModAt7PQvcgIknI3KwfzcAp9YQUSe4CWw=",
         "ref": "uni2work",
-        "rev": "f78fca2504bb767d632a3bac8dbbc23367eff0e9",
-        "revCount": 1220,
+        "rev": "71a630edaf5f22c464e24fac8d9d310f4055ea1f",
+        "revCount": 1202,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptonite.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptonite.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git"
       }
     },
     "encoding": {
@@ -160,12 +160,12 @@
         "rev": "22fc3bb14841d8d50997aa47f1be3852e666f787",
         "revCount": 162,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/encoding.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/encoding.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git"
       }
     },
     "esqueleto": {
@@ -177,12 +177,12 @@
         "rev": "e18dd125c5ea26fa4e88bed079b61d8c1365ee37",
         "revCount": 708,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/esqueleto.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/esqueleto.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git"
       }
     },
     "flake-utils": {
@@ -310,12 +310,12 @@
         "rev": "01afaf599ba6f8a9d804c269e91d3190b249d3f0",
         "revCount": 61,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/ldap-client.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/ldap-client.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git"
       }
     },
     "memcached-binary": {
@@ -327,29 +327,29 @@
         "rev": "b7071df50bad3a251a544b984e4bf98fa09b8fae",
         "revCount": 28,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/memcached-binary.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/memcached-binary.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git"
       }
     },
     "minio-hs": {
       "flake": false,
       "locked": {
-        "lastModified": 1705548354,
-        "narHash": "sha256-wuJYScDu1hGlasE4rzUEi9ouvEiQYWcHF9jRngiQ3Z4=",
+        "lastModified": 1597069863,
+        "narHash": "sha256-JmMajaLT4+zt+w2koDkaloFL8ugmrQBlcYKj+78qn9M=",
         "ref": "uni2work",
-        "rev": "fafc203e1bace1998264d1ce4340fb801e877b51",
-        "revCount": 223,
+        "rev": "42103ab247057c04c8ce7a83d9d4c160713a3df1",
+        "revCount": 197,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/minio-hs.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/minio-hs.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git"
       }
     },
     "nix-tools": {
@@ -528,12 +528,12 @@
         "rev": "b9d76def10da1260c7f6aa82bda32111f37a952b",
         "revCount": 174,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/serversession.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/serversession.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git"
       }
     },
     "stackage": {
@@ -576,29 +576,29 @@
         "rev": "dc928c3a456074b8777603bea20e81937321777f",
         "revCount": 114,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/xss-sanitize.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/xss-sanitize.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git"
       }
     },
     "yesod": {
       "flake": false,
       "locked": {
-        "lastModified": 1705542497,
-        "narHash": "sha256-DYri6G3LeL3Gu11K0gAcUOxMwyKrLVkNnb5oTjHKRro=",
+        "lastModified": 1625061191,
+        "narHash": "sha256-K0X2MwUStChml1DlJ7t4yBMDwrMe6j/780nJtSy9Hss=",
         "ref": "uni2work",
-        "rev": "9f8d26371d4760f8985e7bbe00c3ac16be1301bc",
-        "revCount": 5208,
+        "rev": "a59f63e0336ee61f7a90b8778e9147305d3127bb",
+        "revCount": 5053,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/yesod.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/yesod.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
       }
     },
     "zip-stream": {
@@ -610,12 +610,12 @@
         "rev": "843683d024f767de236f74d24a3348f69181a720",
         "revCount": 39,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/zip-stream.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/zip-stream.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git"
       }
     }
   },
diff --git a/flake.nix b/flake.nix
index 70f4146ef..2ecc482e0 100644
--- a/flake.nix
+++ b/flake.nix
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen 
+# SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -29,59 +29,59 @@
     };
 
     encoding = {
-      url = "git+https://gitlab.uniworx.de/haskell/encoding.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git?ref=uni2work";
       flake = false;
     };
     memcached-binary = {
-      url = "git+https://gitlab.uniworx.de/haskell/memcached-binary.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git?ref=uni2work";
       flake = false;
     };
     conduit-resumablesink = {
-      url = "git+https://gitlab.uniworx.de/haskell/conduit-resumablesink.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git?ref=uni2work";
       flake = false;
     };
     HaskellNet-SSL = {
-      url = "git+https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git?ref=uni2work";
       flake = false;
     };
     ldap-client = {
-      url = "git+https://gitlab.uniworx.de/haskell/ldap-client.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git?ref=uni2work";
       flake = false;
     };
     serversession = {
-      url = "git+https://gitlab.uniworx.de/haskell/serversession.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git?ref=uni2work";
       flake = false;
     };
     xss-sanitize = {
-      url = "git+https://gitlab.uniworx.de/haskell/xss-sanitize.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git?ref=uni2work";
       flake = false;
     };
     colonnade = {
-      url = "git+https://gitlab.uniworx.de/haskell/colonnade.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git?ref=uni2work";
       flake = false;
     };
     minio-hs = {
-      url = "git+https://gitlab.uniworx.de/haskell/minio-hs.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git?ref=uni2work";
       flake = false;
     };
     cryptoids = {
-      url = "git+https://gitlab.uniworx.de/haskell/cryptoids.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git?ref=uni2work";
       flake = false;
     };
     zip-stream = {
-      url = "git+https://gitlab.uniworx.de/haskell/zip-stream.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git?ref=uni2work";
       flake = false;
     };
     yesod = {
-      url = "git+https://gitlab.uniworx.de/haskell/yesod.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git?ref=uni2work";
       flake = false;
     };
     cryptonite = {
-      url = "git+https://gitlab.uniworx.de/haskell/cryptonite.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git?ref=uni2work";
       flake = false;
     };
     esqueleto = {
-      url = "git+https://gitlab.uniworx.de/haskell/esqueleto.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git?ref=uni2work";
       flake = false;
     };
   };
diff --git a/nix/uniworx/backend.nix b/nix/uniworx/backend.nix
index 3cc0bcd19..03fdb8431 100644
--- a/nix/uniworx/backend.nix
+++ b/nix/uniworx/backend.nix
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost 
+# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Steffen Jost 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,7 @@
 with prev.lib;
 
 let
-  haskellInputs = ["encoding" "memcached-binary" "conduit-resumablesink" "HaskellNet-SSL" "ldap-client" "serversession" "xss-sanitize" "colonnade" "minio-hs" "cryptoids" "zip-stream" "yesod" "yesod-auth-oauth2" "cryptonite" "esqueleto"];
+  haskellInputs = ["encoding" "memcached-binary" "conduit-resumablesink" "HaskellNet-SSL" "ldap-client" "serversession" "xss-sanitize" "colonnade" "minio-hs" "cryptoids" "zip-stream" "yesod" "cryptonite" "esqueleto"];
 in {
   uniworx = final.haskell-nix.stackProject {
     src = prev.stdenv.mkDerivation {
@@ -53,7 +53,6 @@ in {
           yesod-persistent.src = "${inputs.yesod}/yesod-persistent";
           yesod-form.src = "${inputs.yesod}/yesod-form";
           yesod-auth.src = "${inputs.yesod}/yesod-auth";
-          yesod-auth-oauth2.src = inputs.yesod-auth-oauth2;
           yesod-test.src = "${inputs.yesod}/yesod-test";
           cryptonite.src = inputs.cryptonite;
           esqueleto.src = inputs.esqueleto;
diff --git a/package.yaml b/package.yaml
index 4ca561014..809c0cb4b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -127,7 +127,6 @@ dependencies:
   - mono-traversable
   - mono-traversable-keys
   - lens-aeson
-  - attoparsec-aeson
   - systemd
   - streaming-commons
   - unix
diff --git a/src/Application.hs b/src/Application.hs
index 271d09068..bc1ea2bec 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -61,7 +61,7 @@ import Jobs
 
 import qualified Data.Text.Encoding as Text
 
-import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
+import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped)
 import Yesod.Auth.Util.PasswordStore
 
 import qualified Data.ByteString.Lazy as LBS
@@ -349,7 +349,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 #ifdef DEVELOPMENT
       oauth2Plugins <- liftIO $ sequence
         [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
-        , return $ oauth2AzureADScoped ["openid", "profile", "offline_access"] "42" "shhh"
+        , return $ oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] "42" "42" "shhh"
         ]
 #else
       let -- Auth Plugins
@@ -366,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do
             -> error "Tenant ID missing!"
         oauth2Plugins
           | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
-            -> singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
+            -> singleton $ oauth2AzureADv2Scoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
           | otherwise
             -> mempty
 #endif
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 88bcff790..97495c1d7 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -118,15 +118,15 @@ instance FromJSON UserID where
 azureMockServer :: YesodAuth m => String -> AuthPlugin m
 azureMockServer port =
   let oa = OAuth2
-            { oauthClientId = "42"
-            , oauthClientSecret = Just "shhh"
-            , oauthOAuthorizeEndpoint = fromString (mockServerURL <> "/auth")
+            { oauth2ClientId = "42"
+            , oauth2ClientSecret = Just "shhh"
+            , oauth2AuthorizeEndpoint = fromString (mockServerURL <> "/auth")
               `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
                           , ("response_type", "code id_token")
                           , ("nonce", "Foo") -- TODO generate meaningful value
                           ]
-            , oauthAccessTokenEndpoint = fromString $ mockServerURL <> "/token"
-            , oauthCallback = Nothing
+            , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
+            , oauth2RedirectUri = Nothing
             }
       mockServerURL = "http://localhost:" <> fromString port
       profileSrc = fromString $ mockServerURL <> "/users/me"
diff --git a/stack-flake.yaml b/stack-flake.yaml
index 7618a4e36..09e2dd321 100644
--- a/stack-flake.yaml
+++ b/stack-flake.yaml
@@ -82,9 +82,5 @@ extra-deps:
 
   - servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755
 
-  - yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
-  - attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
-  - integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
-
 resolver: lts-18.0
 allow-newer: true
diff --git a/stack.yaml b/stack.yaml
index 2c7784d47..e5b66c6db 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
+# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -26,33 +26,33 @@ packages:
   - .
 
 extra-deps:
-  - git: https://gitlab.uniworx.de/haskell/encoding.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-  - git: https://gitlab.uniworx.de/haskell/memcached-binary.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-  - git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
   - git: https://github.com/jtdaugherty/HaskellNet.git
     commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
-  - git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-  - git: https://gitlab.uniworx.de/haskell/ldap-client.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-  - git: https://gitlab.uniworx.de/haskell/serversession.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
     subdirs:
       - serversession
       - serversession-backend-acid-state
-  - git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
     commit: dc928c3a456074b8777603bea20e81937321777f
-  - git: https://gitlab.uniworx.de/haskell/colonnade.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
     subdirs:
       - colonnade
-  - git: https://gitlab.uniworx.de/haskell/minio-hs.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
 
-  - git: https://gitlab.uniworx.de/haskell/cryptoids.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
     subdirs:
       - cryptoids-class
@@ -67,10 +67,10 @@ extra-deps:
       - gearhash
       - fastcdc
 
-  - git: https://gitlab.uniworx.de/haskell/zip-stream.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
     commit: 843683d024f767de236f74d24a3348f69181a720
 
-  - git: https://gitlab.uniworx.de/haskell/yesod.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb
     subdirs:
       - yesod-core
@@ -88,10 +88,13 @@ extra-deps:
       - yesod-eventsource
       - yesod-websockets
 
-  - git: https://gitlab.uniworx.de/haskell/cryptonite.git
+  - git: https://github.com/freckle/yesod-auth-oauth2
+    commit: 11948a65c405f1a99ccb327d328d416e492542a1
+
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
 
-  - git: https://gitlab.uniworx.de/haskell/esqueleto.git
+  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
 
   - classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
@@ -120,9 +123,5 @@ extra-deps:
   - saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198
   - persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601
 
-  - yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
-  - attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
-  - integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
-
 resolver: lts-18.0
 allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 366f7b609..d6c9f21c4 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -6,7 +6,7 @@
 packages:
 - completed:
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-    git: https://gitlab.uniworx.de/haskell/encoding.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
     name: encoding
     pantry-tree:
       sha256: fec12328951021bb4d9326ae0b35f0c459e65f28442366efd4366cd1e18abe19
@@ -14,10 +14,10 @@ packages:
     version: 0.8.2
   original:
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-    git: https://gitlab.uniworx.de/haskell/encoding.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
 - completed:
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-    git: https://gitlab.uniworx.de/haskell/memcached-binary.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
     name: memcached-binary
     pantry-tree:
       sha256: 0da0539b7b9a56d03a116dcd666bc1bbbef085659910420849484d1418aa0857
@@ -25,10 +25,10 @@ packages:
     version: 0.2.0
   original:
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-    git: https://gitlab.uniworx.de/haskell/memcached-binary.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
 - completed:
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
-    git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
     name: conduit-resumablesink
     pantry-tree:
       sha256: 0cccf4684bbd84f81d2d3d53dd81c46cb103b5322f1d8e89e9b222211281e1b7
@@ -36,7 +36,7 @@ packages:
     version: '0.3'
   original:
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
-    git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
 - completed:
     commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
     git: https://github.com/jtdaugherty/HaskellNet.git
@@ -50,7 +50,7 @@ packages:
     git: https://github.com/jtdaugherty/HaskellNet.git
 - completed:
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-    git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
     name: HaskellNet-SSL
     pantry-tree:
       sha256: 95dcec22fdb8af986e59f0f60aa76d4a48f34a546dca799bd571e1d183f773e0
@@ -58,10 +58,10 @@ packages:
     version: 0.3.4.1
   original:
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-    git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
 - completed:
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-    git: https://gitlab.uniworx.de/haskell/ldap-client.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
     name: ldap-client
     pantry-tree:
       sha256: 3fa8f102427b437b2baaec15cf884e88b47a1621b1c3fd4d8919f0263fde8656
@@ -69,10 +69,10 @@ packages:
     version: 0.4.0
   original:
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-    git: https://gitlab.uniworx.de/haskell/ldap-client.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
 - completed:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.uniworx.de/haskell/serversession.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
     name: serversession
     pantry-tree:
       sha256: 83ac78a987399db3da62f84bbd335fead11aadebd57251d0688127fca984db23
@@ -81,11 +81,11 @@ packages:
     version: 1.0.2
   original:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.uniworx.de/haskell/serversession.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
     subdir: serversession
 - completed:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.uniworx.de/haskell/serversession.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
     name: serversession-backend-acid-state
     pantry-tree:
       sha256: 4804260c6245c12e1728c78dd33bf16e95b7f2b69b38b6900a4e65b1ef3e04b7
@@ -94,11 +94,11 @@ packages:
     version: 1.0.4
   original:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.uniworx.de/haskell/serversession.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
     subdir: serversession-backend-acid-state
 - completed:
     commit: dc928c3a456074b8777603bea20e81937321777f
-    git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
     name: xss-sanitize
     pantry-tree:
       sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975
@@ -106,10 +106,10 @@ packages:
     version: 0.3.6
   original:
     commit: dc928c3a456074b8777603bea20e81937321777f
-    git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
 - completed:
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
-    git: https://gitlab.uniworx.de/haskell/colonnade.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
     name: colonnade
     pantry-tree:
       sha256: 392393652cc0f354d351482557b9385c8e6122e706359b030373656565f2e045
@@ -118,11 +118,11 @@ packages:
     version: 1.2.0.2
   original:
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
-    git: https://gitlab.uniworx.de/haskell/colonnade.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
     subdir: colonnade
 - completed:
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
-    git: https://gitlab.uniworx.de/haskell/minio-hs.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
     name: minio-hs
     pantry-tree:
       sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
@@ -130,10 +130,10 @@ packages:
     version: 1.5.2
   original:
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
-    git: https://gitlab.uniworx.de/haskell/minio-hs.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     name: cryptoids-class
     pantry-tree:
       sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203
@@ -142,11 +142,11 @@ packages:
     version: 0.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     subdir: cryptoids-class
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     name: cryptoids-types
     pantry-tree:
       sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e
@@ -155,11 +155,11 @@ packages:
     version: 1.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     subdir: cryptoids-types
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     name: cryptoids
     pantry-tree:
       sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb
@@ -168,11 +168,11 @@ packages:
     version: 0.5.1.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     subdir: cryptoids
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     name: filepath-crypto
     pantry-tree:
       sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9
@@ -181,11 +181,11 @@ packages:
     version: 0.1.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     subdir: filepath-crypto
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     name: uuid-crypto
     pantry-tree:
       sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4
@@ -194,7 +194,7 @@ packages:
     version: 1.4.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.uniworx.de/haskell/cryptoids.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
     subdir: uuid-crypto
 - completed:
     commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d
@@ -224,7 +224,7 @@ packages:
     subdir: fastcdc
 - completed:
     commit: 843683d024f767de236f74d24a3348f69181a720
-    git: https://gitlab.uniworx.de/haskell/zip-stream.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
     name: zip-stream
     pantry-tree:
       sha256: 0da8bc38d73034962d2e2d1a7586b6dee848a629319fce9cbbf578348c61118c
@@ -232,10 +232,10 @@ packages:
     version: 0.2.0.1
   original:
     commit: 843683d024f767de236f74d24a3348f69181a720
-    git: https://gitlab.uniworx.de/haskell/zip-stream.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-core
     pantry-tree:
       sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a
@@ -244,11 +244,11 @@ packages:
     version: 1.6.20.2
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-core
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-static
     pantry-tree:
       sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06
@@ -257,11 +257,11 @@ packages:
     version: 1.6.1.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-static
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-persistent
     pantry-tree:
       sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c
@@ -270,11 +270,11 @@ packages:
     version: 1.6.0.7
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-persistent
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-newsfeed
     pantry-tree:
       sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099
@@ -283,11 +283,11 @@ packages:
     version: 1.7.0.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-newsfeed
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-form
     pantry-tree:
       sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f
@@ -296,11 +296,11 @@ packages:
     version: 1.7.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-form
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-form-multi
     pantry-tree:
       sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6
@@ -309,11 +309,11 @@ packages:
     version: 1.7.0.2
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-form-multi
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-auth
     pantry-tree:
       sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08
@@ -322,11 +322,11 @@ packages:
     version: 1.6.10.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-auth
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-auth-oauth
     pantry-tree:
       sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4
@@ -335,11 +335,11 @@ packages:
     version: 1.6.0.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-auth-oauth
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-sitemap
     pantry-tree:
       sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27
@@ -348,11 +348,11 @@ packages:
     version: 1.6.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-sitemap
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-test
     pantry-tree:
       sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1
@@ -361,11 +361,11 @@ packages:
     version: 1.6.12
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-test
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-bin
     pantry-tree:
       sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8
@@ -374,11 +374,11 @@ packages:
     version: 1.6.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-bin
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod
     pantry-tree:
       sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42
@@ -387,11 +387,11 @@ packages:
     version: 1.6.1.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-eventsource
     pantry-tree:
       sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2
@@ -400,11 +400,11 @@ packages:
     version: 1.6.0.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-eventsource
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     name: yesod-websockets
     pantry-tree:
       sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5
@@ -413,11 +413,22 @@ packages:
     version: 0.3.0.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.uniworx.de/haskell/yesod.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
     subdir: yesod-websockets
+- completed:
+    commit: 11948a65c405f1a99ccb327d328d416e492542a1
+    git: https://github.com/freckle/yesod-auth-oauth2
+    name: yesod-auth-oauth2
+    pantry-tree:
+      sha256: a68ec51e1008c315dd15e81cc3ac1f4e2adfd3db623259395757ecae2787cef2
+      size: 4277
+    version: 0.7.1.3
+  original:
+    commit: 11948a65c405f1a99ccb327d328d416e492542a1
+    git: https://github.com/freckle/yesod-auth-oauth2
 - completed:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
-    git: https://gitlab.uniworx.de/haskell/cryptonite.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
     name: cryptonite
     pantry-tree:
       sha256: 19e49259fa5e3c257495d72b3c7c3c49537aeafd508c780c2430ddca2ef71a91
@@ -425,10 +436,10 @@ packages:
     version: '0.29'
   original:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
-    git: https://gitlab.uniworx.de/haskell/cryptonite.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
 - completed:
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
-    git: https://gitlab.uniworx.de/haskell/esqueleto.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
     name: esqueleto
     pantry-tree:
       sha256: 8a93dc98eb4529ff64aa5bcdaa3c00dcdf0378033ad675864e2b0fc3d869d947
@@ -436,7 +447,7 @@ packages:
     version: 3.5.4.0
   original:
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
-    git: https://gitlab.uniworx.de/haskell/esqueleto.git
+    git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
 - completed:
     hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
     pantry-tree:
@@ -535,27 +546,6 @@ packages:
       size: 1059
   original:
     hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601
-- completed:
-    hackage: yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
-    pantry-tree:
-      sha256: 56094dc446a82f1c3abb1f7fa2a439855c5bbb7463c20a95d93673b27a90cbcc
-      size: 1919
-  original:
-    hackage: yesod-auth-oauth2-0.6.2.0@sha256:3301232a6ffdf095710dd25e0da9b948d5a4f5c3aaee1e2d5adfadfe395c2c89,3389
-- completed:
-    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
-    pantry-tree:
-      sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a
-      size: 114
-  original:
-    hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154
-- completed:
-    hackage: integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
-    pantry-tree:
-      sha256: 5684bd08f7edbadbff77d84075b37cdf41309bd8a0dc23bcea6ffbf4497adb7f
-      size: 509
-  original:
-    hackage: integer-conversion-0.1.0.1@sha256:0e57a82635323f015b5d6c242bcfbbeeaa9854fe9c8058e57052254dbb24bb14,2250
 snapshots:
 - completed:
     sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0

From cba9cadb41a1ea4cbdc7bd0fdf2427be8314a031 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 19 Mar 2024 15:11:19 +0100
Subject: [PATCH 170/178] chore: update backend dependency sources

---
 stack.yaml      |  30 ++++++------
 stack.yaml.lock | 128 ++++++++++++++++++++++++------------------------
 2 files changed, 79 insertions(+), 79 deletions(-)

diff --git a/stack.yaml b/stack.yaml
index e5b66c6db..4d8ca60f8 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost 
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -26,33 +26,33 @@ packages:
   - .
 
 extra-deps:
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
+  - git: https://gitlab.uniworx.de/haskell/encoding.git
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
+  - git: https://gitlab.uniworx.de/haskell/memcached-binary.git
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
+  - git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
   - git: https://github.com/jtdaugherty/HaskellNet.git
     commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
+  - git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
+  - git: https://gitlab.uniworx.de/haskell/ldap-client.git
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+  - git: https://gitlab.uniworx.de/haskell/serversession.git
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
     subdirs:
       - serversession
       - serversession-backend-acid-state
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
+  - git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
     commit: dc928c3a456074b8777603bea20e81937321777f
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
+  - git: https://gitlab.uniworx.de/haskell/colonnade.git
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
     subdirs:
       - colonnade
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
+  - git: https://gitlab.uniworx.de/haskell/minio-hs.git
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+  - git: https://gitlab.uniworx.de/haskell/cryptoids.git
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
     subdirs:
       - cryptoids-class
@@ -67,10 +67,10 @@ extra-deps:
       - gearhash
       - fastcdc
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
+  - git: https://gitlab.uniworx.de/haskell/zip-stream.git
     commit: 843683d024f767de236f74d24a3348f69181a720
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+  - git: https://gitlab.uniworx.de/haskell/yesod.git
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb
     subdirs:
       - yesod-core
@@ -91,10 +91,10 @@ extra-deps:
   - git: https://github.com/freckle/yesod-auth-oauth2
     commit: 11948a65c405f1a99ccb327d328d416e492542a1
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
+  - git: https://gitlab.uniworx.de/haskell/cryptonite.git
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
 
-  - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
+  - git: https://gitlab.uniworx.de/haskell/esqueleto.git
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
 
   - classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
diff --git a/stack.yaml.lock b/stack.yaml.lock
index d6c9f21c4..17f701258 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -6,7 +6,7 @@
 packages:
 - completed:
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
+    git: https://gitlab.uniworx.de/haskell/encoding.git
     name: encoding
     pantry-tree:
       sha256: fec12328951021bb4d9326ae0b35f0c459e65f28442366efd4366cd1e18abe19
@@ -14,10 +14,10 @@ packages:
     version: 0.8.2
   original:
     commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git
+    git: https://gitlab.uniworx.de/haskell/encoding.git
 - completed:
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
+    git: https://gitlab.uniworx.de/haskell/memcached-binary.git
     name: memcached-binary
     pantry-tree:
       sha256: 0da0539b7b9a56d03a116dcd666bc1bbbef085659910420849484d1418aa0857
@@ -25,10 +25,10 @@ packages:
     version: 0.2.0
   original:
     commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git
+    git: https://gitlab.uniworx.de/haskell/memcached-binary.git
 - completed:
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
+    git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
     name: conduit-resumablesink
     pantry-tree:
       sha256: 0cccf4684bbd84f81d2d3d53dd81c46cb103b5322f1d8e89e9b222211281e1b7
@@ -36,7 +36,7 @@ packages:
     version: '0.3'
   original:
     commit: cbea6159c2975d42f948525e03e12fc390da53c5
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git
+    git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git
 - completed:
     commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
     git: https://github.com/jtdaugherty/HaskellNet.git
@@ -50,7 +50,7 @@ packages:
     git: https://github.com/jtdaugherty/HaskellNet.git
 - completed:
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
+    git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
     name: HaskellNet-SSL
     pantry-tree:
       sha256: 95dcec22fdb8af986e59f0f60aa76d4a48f34a546dca799bd571e1d183f773e0
@@ -58,10 +58,10 @@ packages:
     version: 0.3.4.1
   original:
     commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git
+    git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git
 - completed:
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
+    git: https://gitlab.uniworx.de/haskell/ldap-client.git
     name: ldap-client
     pantry-tree:
       sha256: 3fa8f102427b437b2baaec15cf884e88b47a1621b1c3fd4d8919f0263fde8656
@@ -69,10 +69,10 @@ packages:
     version: 0.4.0
   original:
     commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git
+    git: https://gitlab.uniworx.de/haskell/ldap-client.git
 - completed:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     name: serversession
     pantry-tree:
       sha256: 83ac78a987399db3da62f84bbd335fead11aadebd57251d0688127fca984db23
@@ -81,11 +81,11 @@ packages:
     version: 1.0.2
   original:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     subdir: serversession
 - completed:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     name: serversession-backend-acid-state
     pantry-tree:
       sha256: 4804260c6245c12e1728c78dd33bf16e95b7f2b69b38b6900a4e65b1ef3e04b7
@@ -94,11 +94,11 @@ packages:
     version: 1.0.4
   original:
     commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git
+    git: https://gitlab.uniworx.de/haskell/serversession.git
     subdir: serversession-backend-acid-state
 - completed:
     commit: dc928c3a456074b8777603bea20e81937321777f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
+    git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
     name: xss-sanitize
     pantry-tree:
       sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975
@@ -106,10 +106,10 @@ packages:
     version: 0.3.6
   original:
     commit: dc928c3a456074b8777603bea20e81937321777f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git
+    git: https://gitlab.uniworx.de/haskell/xss-sanitize.git
 - completed:
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
+    git: https://gitlab.uniworx.de/haskell/colonnade.git
     name: colonnade
     pantry-tree:
       sha256: 392393652cc0f354d351482557b9385c8e6122e706359b030373656565f2e045
@@ -118,11 +118,11 @@ packages:
     version: 1.2.0.2
   original:
     commit: f8170266ab25b533576e96715bedffc5aa4f19fa
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git
+    git: https://gitlab.uniworx.de/haskell/colonnade.git
     subdir: colonnade
 - completed:
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
+    git: https://gitlab.uniworx.de/haskell/minio-hs.git
     name: minio-hs
     pantry-tree:
       sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
@@ -130,10 +130,10 @@ packages:
     version: 1.5.2
   original:
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git
+    git: https://gitlab.uniworx.de/haskell/minio-hs.git
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: cryptoids-class
     pantry-tree:
       sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203
@@ -142,11 +142,11 @@ packages:
     version: 0.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: cryptoids-class
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: cryptoids-types
     pantry-tree:
       sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e
@@ -155,11 +155,11 @@ packages:
     version: 1.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: cryptoids-types
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: cryptoids
     pantry-tree:
       sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb
@@ -168,11 +168,11 @@ packages:
     version: 0.5.1.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: cryptoids
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: filepath-crypto
     pantry-tree:
       sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9
@@ -181,11 +181,11 @@ packages:
     version: 0.1.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: filepath-crypto
 - completed:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     name: uuid-crypto
     pantry-tree:
       sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4
@@ -194,7 +194,7 @@ packages:
     version: 1.4.0.0
   original:
     commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git
+    git: https://gitlab.uniworx.de/haskell/cryptoids.git
     subdir: uuid-crypto
 - completed:
     commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d
@@ -224,7 +224,7 @@ packages:
     subdir: fastcdc
 - completed:
     commit: 843683d024f767de236f74d24a3348f69181a720
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
+    git: https://gitlab.uniworx.de/haskell/zip-stream.git
     name: zip-stream
     pantry-tree:
       sha256: 0da8bc38d73034962d2e2d1a7586b6dee848a629319fce9cbbf578348c61118c
@@ -232,10 +232,10 @@ packages:
     version: 0.2.0.1
   original:
     commit: 843683d024f767de236f74d24a3348f69181a720
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git
+    git: https://gitlab.uniworx.de/haskell/zip-stream.git
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-core
     pantry-tree:
       sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a
@@ -244,11 +244,11 @@ packages:
     version: 1.6.20.2
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-core
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-static
     pantry-tree:
       sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06
@@ -257,11 +257,11 @@ packages:
     version: 1.6.1.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-static
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-persistent
     pantry-tree:
       sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c
@@ -270,11 +270,11 @@ packages:
     version: 1.6.0.7
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-persistent
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-newsfeed
     pantry-tree:
       sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099
@@ -283,11 +283,11 @@ packages:
     version: 1.7.0.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-newsfeed
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-form
     pantry-tree:
       sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f
@@ -296,11 +296,11 @@ packages:
     version: 1.7.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-form
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-form-multi
     pantry-tree:
       sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6
@@ -309,11 +309,11 @@ packages:
     version: 1.7.0.2
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-form-multi
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-auth
     pantry-tree:
       sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08
@@ -322,11 +322,11 @@ packages:
     version: 1.6.10.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-auth
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-auth-oauth
     pantry-tree:
       sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4
@@ -335,11 +335,11 @@ packages:
     version: 1.6.0.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-auth-oauth
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-sitemap
     pantry-tree:
       sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27
@@ -348,11 +348,11 @@ packages:
     version: 1.6.0
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-sitemap
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-test
     pantry-tree:
       sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1
@@ -361,11 +361,11 @@ packages:
     version: 1.6.12
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-test
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-bin
     pantry-tree:
       sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8
@@ -374,11 +374,11 @@ packages:
     version: 1.6.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-bin
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod
     pantry-tree:
       sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42
@@ -387,11 +387,11 @@ packages:
     version: 1.6.1.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-eventsource
     pantry-tree:
       sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2
@@ -400,11 +400,11 @@ packages:
     version: 1.6.0.1
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-eventsource
 - completed:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     name: yesod-websockets
     pantry-tree:
       sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5
@@ -413,7 +413,7 @@ packages:
     version: 0.3.0.3
   original:
     commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
+    git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-websockets
 - completed:
     commit: 11948a65c405f1a99ccb327d328d416e492542a1
@@ -428,7 +428,7 @@ packages:
     git: https://github.com/freckle/yesod-auth-oauth2
 - completed:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
+    git: https://gitlab.uniworx.de/haskell/cryptonite.git
     name: cryptonite
     pantry-tree:
       sha256: 19e49259fa5e3c257495d72b3c7c3c49537aeafd508c780c2430ddca2ef71a91
@@ -436,10 +436,10 @@ packages:
     version: '0.29'
   original:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git
+    git: https://gitlab.uniworx.de/haskell/cryptonite.git
 - completed:
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
+    git: https://gitlab.uniworx.de/haskell/esqueleto.git
     name: esqueleto
     pantry-tree:
       sha256: 8a93dc98eb4529ff64aa5bcdaa3c00dcdf0378033ad675864e2b0fc3d869d947
@@ -447,7 +447,7 @@ packages:
     version: 3.5.4.0
   original:
     commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37
-    git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git
+    git: https://gitlab.uniworx.de/haskell/esqueleto.git
 - completed:
     hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
     pantry-tree:

From cea64da34dc462c5388f44ecc55d9dbd86b37ba3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 19 Mar 2024 16:27:57 +0100
Subject: [PATCH 171/178] chore(oauth2): downgrade yesod-auth-oauth2 to
 v0.6.3.4

---
 src/Application.hs |  6 +++---
 src/Auth/OAuth2.hs | 10 +++++-----
 stack.yaml         |  2 +-
 stack.yaml.lock    | 10 +++++-----
 4 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index bc1ea2bec..fca9e7038 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -61,7 +61,7 @@ import Jobs
 
 import qualified Data.Text.Encoding as Text
 
-import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped)
+import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
 import Yesod.Auth.Util.PasswordStore
 
 import qualified Data.ByteString.Lazy as LBS
@@ -349,7 +349,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 #ifdef DEVELOPMENT
       oauth2Plugins <- liftIO $ sequence
         [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
-        , return $ oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] "42" "42" "shhh"
+        , return $ oauth2AzureADScoped ["openid", "profile", "offline_access"] "42" "shhh"
         ]
 #else
       let -- Auth Plugins
@@ -366,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do
             -> error "Tenant ID missing!"
         oauth2Plugins
           | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
-            -> singleton $ oauth2AzureADv2Scoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
+            -> singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfClientId azureConfClientSecret
           | otherwise
             -> mempty
 #endif
diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs
index 97495c1d7..88bcff790 100644
--- a/src/Auth/OAuth2.hs
+++ b/src/Auth/OAuth2.hs
@@ -118,15 +118,15 @@ instance FromJSON UserID where
 azureMockServer :: YesodAuth m => String -> AuthPlugin m
 azureMockServer port =
   let oa = OAuth2
-            { oauth2ClientId = "42"
-            , oauth2ClientSecret = Just "shhh"
-            , oauth2AuthorizeEndpoint = fromString (mockServerURL <> "/auth")
+            { oauthClientId = "42"
+            , oauthClientSecret = Just "shhh"
+            , oauthOAuthorizeEndpoint = fromString (mockServerURL <> "/auth")
               `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
                           , ("response_type", "code id_token")
                           , ("nonce", "Foo") -- TODO generate meaningful value
                           ]
-            , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
-            , oauth2RedirectUri = Nothing
+            , oauthAccessTokenEndpoint = fromString $ mockServerURL <> "/token"
+            , oauthCallback = Nothing
             }
       mockServerURL = "http://localhost:" <> fromString port
       profileSrc = fromString $ mockServerURL <> "/users/me"
diff --git a/stack.yaml b/stack.yaml
index 4d8ca60f8..7346e8392 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -89,7 +89,7 @@ extra-deps:
       - yesod-websockets
 
   - git: https://github.com/freckle/yesod-auth-oauth2
-    commit: 11948a65c405f1a99ccb327d328d416e492542a1
+    commit: 342dac80e40b10f07694a7e9aa8bab6d03ed6d66
 
   - git: https://gitlab.uniworx.de/haskell/cryptonite.git
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 17f701258..40712391d 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -416,15 +416,15 @@ packages:
     git: https://gitlab.uniworx.de/haskell/yesod.git
     subdir: yesod-websockets
 - completed:
-    commit: 11948a65c405f1a99ccb327d328d416e492542a1
+    commit: 342dac80e40b10f07694a7e9aa8bab6d03ed6d66
     git: https://github.com/freckle/yesod-auth-oauth2
     name: yesod-auth-oauth2
     pantry-tree:
-      sha256: a68ec51e1008c315dd15e81cc3ac1f4e2adfd3db623259395757ecae2787cef2
-      size: 4277
-    version: 0.7.1.3
+      sha256: 22e8be5c8128e2f0fb976cb904ac93cefb49e6feef6bcadb7746641be11dcb13
+      size: 3054
+    version: 0.6.3.4
   original:
-    commit: 11948a65c405f1a99ccb327d328d416e492542a1
+    commit: 342dac80e40b10f07694a7e9aa8bab6d03ed6d66
     git: https://github.com/freckle/yesod-auth-oauth2
 - completed:
     commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f

From 1dd83af6aacf5f9269f53277728fbfeb5c2ec3e5 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Tue, 19 Mar 2024 22:45:04 +0100
Subject: [PATCH 172/178] chore(oauth2): fix syntax

---
 src/Application.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index fca9e7038..837f3a536 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -366,9 +366,9 @@ makeFoundation appSettings''@AppSettings{..} = do
             -> error "Tenant ID missing!"
         oauth2Plugins
           | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
-            -> singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfClientId azureConfClientSecret
+            = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfClientId azureConfClientSecret
           | otherwise
-            -> mempty
+            = mempty
 #endif
       let appAuthPlugins = oauth2Plugins
 

From 274c86a82012c50d9b80a626e60ac3777736db97 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 20 Mar 2024 15:56:30 +0100
Subject: [PATCH 173/178] chore(oauth2): fix conf constructors in !develop

---
 src/Application.hs | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index bf5889899..4163209f3 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -59,6 +59,7 @@ import System.Directory
 
 import Jobs
 
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)
@@ -355,18 +356,18 @@ makeFoundation appSettings''@AppSettings{..} = do
 #else
       let -- Auth Plugins
         loadPlugin p prefix = do -- Loads given YesodAuthPlugin
-          mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzure . _azureConfClientId
-          mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzure . _azureConfClientSecret
+          mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientId
+          mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientSecret
           let mArgs = (,) <$> mID <*> mSecret
           guard $ isJust mArgs
           return . uncurry p $ fromJust mArgs
         tenantID = case appUserAuthConf of
-          UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..})
+          UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..})
             -> Text.pack azureConfTenantId
           _other
             -> error "Tenant ID missing!"
         oauth2Plugins
-          | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
+          | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) appUserAuthConf
             = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfClientId azureConfClientSecret
           | otherwise
             = mempty

From b1cb45ac7efbaab3c806932b162e87c95c68823c Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Wed, 20 Mar 2024 18:24:39 +0100
Subject: [PATCH 174/178] chore(oauth2): fix !develop syntax contd

---
 src/Application.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 4163209f3..23275f94a 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -363,11 +363,11 @@ makeFoundation appSettings''@AppSettings{..} = do
           return . uncurry p $ fromJust mArgs
         tenantID = case appUserAuthConf of
           UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..})
-            -> Text.pack azureConfTenantId
+            -> tshow azureConfTenantId
           _other
             -> error "Tenant ID missing!"
         oauth2Plugins
-          | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) appUserAuthConf
+          | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) <- appUserAuthConf
             = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfClientId azureConfClientSecret
           | otherwise
             = mempty

From 0599ec251268cd6b9ca06836f003f34ff6279b86 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 21 Mar 2024 00:27:43 +0100
Subject: [PATCH 175/178] chore(oauth2): fix type

---
 src/Application.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Application.hs b/src/Application.hs
index 23275f94a..1aee0f2e0 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -368,7 +368,7 @@ makeFoundation appSettings''@AppSettings{..} = do
             -> error "Tenant ID missing!"
         oauth2Plugins
           | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) <- appUserAuthConf
-            = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) azureConfClientId azureConfClientSecret
+            = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) (tshow azureConfClientId) azureConfClientSecret
           | otherwise
             = mempty
 #endif

From 795c707a1fb4b33ddcd6cc891990543ad085e0e3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 21 Mar 2024 09:16:43 +0100
Subject: [PATCH 176/178] chore(oauth2): remove unused loadPlugin function

---
 src/Application.hs | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 1aee0f2e0..0c92e941c 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -355,12 +355,12 @@ makeFoundation appSettings''@AppSettings{..} = do
         ]
 #else
       let -- Auth Plugins
-        loadPlugin p prefix = do -- Loads given YesodAuthPlugin
-          mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientId
-          mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientSecret
-          let mArgs = (,) <$> mID <*> mSecret
-          guard $ isJust mArgs
-          return . uncurry p $ fromJust mArgs
+        -- loadPlugin p prefix = do -- Loads given YesodAuthPlugin
+        --   mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientId
+        --   mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientSecret
+        --   let mArgs = (,) <$> mID <*> mSecret
+        --   guard $ isJust mArgs
+        --   return . uncurry p $ fromJust mArgs
         tenantID = case appUserAuthConf of
           UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..})
             -> tshow azureConfTenantId

From 619c5975aa547cc7d1efcb0981cbe11c8f024d64 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 21 Mar 2024 14:06:15 +0100
Subject: [PATCH 177/178] chore(oauth2): remove unused import

---
 src/Application.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Application.hs b/src/Application.hs
index 0c92e941c..594378762 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -59,7 +59,6 @@ import System.Directory
 
 import Jobs
 
-import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped)

From 663ad0174090d71a5cd531717ce10d488ec1e5a9 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel 
Date: Thu, 21 Mar 2024 14:14:33 +0100
Subject: [PATCH 178/178] chore(oauth2): remove unused imports and defs

---
 src/Application.hs | 14 +++++---------
 1 file changed, 5 insertions(+), 9 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 594378762..1741d239a 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -125,8 +125,6 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
 
 import qualified System.Clock as Clock
 
-import Data.Maybe (fromJust)
-
 import Utils.Avs
 
 -- Import all relevant handler modules here.
@@ -171,8 +169,6 @@ import Servant.API
 import Servant.Client
 import Network.HTTP.Client.TLS (mkManagerSettings)
 
-import Auth.OAuth2
-
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -360,11 +356,11 @@ makeFoundation appSettings''@AppSettings{..} = do
         --   let mArgs = (,) <$> mID <*> mSecret
         --   guard $ isJust mArgs
         --   return . uncurry p $ fromJust mArgs
-        tenantID = case appUserAuthConf of
-          UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..})
-            -> tshow azureConfTenantId
-          _other
-            -> error "Tenant ID missing!"
+        -- tenantID = case appUserAuthConf of
+        --   UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..})
+        --     -> tshow azureConfTenantId
+        --   _other
+        --     -> error "Tenant ID missing!"
         oauth2Plugins
           | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) <- appUserAuthConf
             = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) (tshow azureConfClientId) azureConfClientSecret