diff --git a/config/settings.yml b/config/settings.yml index d8d6e6534..8e08231d8 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -222,6 +222,10 @@ cookies: http-only: true secure: "_env:COOKIES_SECURE:true" +external-apis-ping-interval: 300 +external-apis-pong-timeout: 600 +external-apis-expiry: 1200 + user-defaults: max-favourites: 0 max-favourite-terms: 2 diff --git a/frontend/src/app.sass b/frontend/src/app.sass index de06febd1..5365d966f 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1449,6 +1449,15 @@ a.breadcrumbs__home &__label grid-area: label +.apidocs + pre + display: block + box-shadow: inset 0 0 4px 4px var(--color-grey-light) + white-space: pre-wrap + overflow-x: auto + tab-size: 2 + padding: 10px + .news__system-messages overflow-y: auto max-height: 75vh diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 363119fa1..f44073739 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -187,4 +187,7 @@ BreadcrumbMessageList: Systemnachrichten BreadcrumbGlossary: Begriffsverzeichnis BreadcrumbLogin !ident-ok: Login BreadcrumbNews: Aktuell -BreadcrumbSubmissionAuthorshipStatements: Eigenständigkeitserklärungen \ No newline at end of file +BreadcrumbSubmissionAuthorshipStatements: Eigenständigkeitserklärungen +BreadcrumbExternalApis: Externe APIs +BreadcrumbApiDocs: API Dokumentation +BreadcrumbSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index 1b2194e4e..8996ca38c 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -188,3 +188,6 @@ BreadcrumbSheetOldUnassigned: Submissions without corrector BreadcrumbLogin: Login BreadcrumbNews: News BreadcrumbSubmissionAuthorshipStatements: Statements of Authorship +BreadcrumbExternalApis: External APIs +BreadcrumbApiDocs: API documentation +BreadcrumbSwagger: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 359e7df30..356d05cfd 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -140,3 +140,5 @@ MenuCourseNewsEdit: Kursnachricht bearbeiten MenuCourseEventNew: Neuer Kurstermin MenuCourseEventEdit: Kurstermin bearbeiten MenuLanguage: Sprache +MenuApiDocs: API-Dokumentation (Englisch) +MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 8fc36a55f..5ff939dcb 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -141,3 +141,5 @@ MenuCourseNewsEdit: Edit course news MenuCourseEventNew: New course occurrence MenuCourseEventEdit: Edit course occurrence MenuLanguage: Language +MenuApiDocs: API documentation +MenuSwagger: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/models/external-apis.model b/models/external-apis.model new file mode 100644 index 000000000..3ac92ee93 --- /dev/null +++ b/models/external-apis.model @@ -0,0 +1,9 @@ +ExternalApi + ident UUID Maybe + authority Jwt + keys JwkSet + baseUrl BaseUrl + config ExternalApiConfig + lastAlive UTCTime + UniqueExternalApiIdent ident !force + deriving Generic \ No newline at end of file diff --git a/package-lock.json b/package-lock.json index 52bd56b93..cd30e13a7 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1341,9 +1341,9 @@ "dev": true }, "@commitlint/cli": { - "version": "17.0.1", - "resolved": "https://registry.npmjs.org/@commitlint/cli/-/cli-17.0.1.tgz", - "integrity": "sha512-5xT1G5pnynR0tk/ms8Ji7yr9lZCeQs4GLVVtyK/gw20w+enoLTVuRKKY9zg88hy9FoCycc/W8iip2xv3c8payg==", + "version": "17.0.2", + "resolved": "https://registry.npmjs.org/@commitlint/cli/-/cli-17.0.2.tgz", + "integrity": "sha512-Axe89Js0YzGGd4gxo3JLlF7yIdjOVpG1LbOorGc6PfYF+drBh14PvarSDLzyd2TNqdylUCq9wb9/A88ZjIdyhA==", "dev": true, "requires": { "@commitlint/format": "^17.0.0", @@ -1359,12 +1359,25 @@ } }, "@commitlint/config-conventional": { - "version": "17.0.0", - "resolved": "https://registry.npmjs.org/@commitlint/config-conventional/-/config-conventional-17.0.0.tgz", - "integrity": "sha512-jttJXBIq3AuQCvUVwxSctCwKfHxxbALE0IB9OIHYCu/eQdOzPxN72pugeZsWDo1VK/T9iFx+MZoPb6Rb1/ylsw==", + "version": "17.0.2", + "resolved": "https://registry.npmjs.org/@commitlint/config-conventional/-/config-conventional-17.0.2.tgz", + "integrity": "sha512-MfP0I/JbxKkzo+HXWB7B3WstGS4BiniotU3d3xQ9gK8cR0DbeZ4MuyGCWF65YDyrcDTS3WlrJ3ndSPA1pqhoPw==", "dev": true, "requires": { - "conventional-changelog-conventionalcommits": "^4.3.1" + "conventional-changelog-conventionalcommits": "^5.0.0" + }, + "dependencies": { + "conventional-changelog-conventionalcommits": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/conventional-changelog-conventionalcommits/-/conventional-changelog-conventionalcommits-5.0.0.tgz", + "integrity": "sha512-lCDbA+ZqVFQGUj7h9QBKoIpLhl8iihkO0nCTyRNzuXtcd7ubODpYB04IFy31JloiJgG0Uovu8ot8oxRzn7Nwtw==", + "dev": true, + "requires": { + "compare-func": "^2.0.0", + "lodash": "^4.17.15", + "q": "^1.5.1" + } + } } }, "@commitlint/config-validator": { @@ -1640,6 +1653,15 @@ "postcss-value-parser": "^4.2.0" } }, + "@csstools/postcss-trigonometric-functions": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/@csstools/postcss-trigonometric-functions/-/postcss-trigonometric-functions-1.0.1.tgz", + "integrity": "sha512-G78CY/+GePc6dDCTUbwI6TTFQ5fs3N9POHhI6v0QzteGpf6ylARiJUNz9HrRKi4eVYBNXjae1W2766iUEFxHlw==", + "dev": true, + "requires": { + "postcss-value-parser": "^4.2.0" + } + }, "@csstools/postcss-unset-value": { "version": "1.0.1", "resolved": "https://registry.npmjs.org/@csstools/postcss-unset-value/-/postcss-unset-value-1.0.1.tgz", @@ -3812,9 +3834,9 @@ "dev": true }, "cacache": { - "version": "16.1.0", - "resolved": "https://registry.npmjs.org/cacache/-/cacache-16.1.0.tgz", - "integrity": "sha512-Pk4aQkwCW82A4jGKFvcGkQFqZcMspfP9YWq9Pr87/ldDvlWf718zeI6KWCdKt/jeihu6BytHRUicJPB1K2k8EQ==", + "version": "16.1.1", + "resolved": "https://registry.npmjs.org/cacache/-/cacache-16.1.1.tgz", + "integrity": "sha512-VDKN+LHyCQXaaYZ7rA/qtkURU+/yYhviUdvqEv2LT6QPZU8jpyzEkEVAcKlKLt5dJ5BRp11ym8lo3NKLluEPLg==", "requires": { "@npmcli/fs": "^2.1.0", "@npmcli/move-file": "^2.0.0", @@ -4101,7 +4123,7 @@ "nth-check": { "version": "2.0.1", "resolved": "https://registry.npmjs.org/nth-check/-/nth-check-2.0.1.tgz", - "integrity": "sha512-WeBOdju8SnzPN5vTUJYxYUxLeXpCaVP5i5e0LF8fg7WORF2Wd7wFX/pk0tYZk7s8T+J7VLy0Da6J1+wCT0AtHg==", + "integrity": "sha512-it1vE95zF6dTT9lBsYbxvqh0Soy4SPowchj0UBGj/V6cTPnXXtQOPUbhZ6CmGzAD/rW22LQK6E96pcdJXk4A4w==", "dev": true, "requires": { "boolbase": "~1.0.0" @@ -4310,9 +4332,9 @@ } }, "commander": { - "version": "9.2.0", - "resolved": "https://registry.npmjs.org/commander/-/commander-9.2.0.tgz", - "integrity": "sha512-e2i4wANQiSXgnrBlIatyHtP1odfUp0BbV5Y5nEGbxtIrStkEOAAzCUirvLBNXHLr7kwLvJl6V+4V3XV9x7Wd9w==" + "version": "9.3.0", + "resolved": "https://registry.npmjs.org/commander/-/commander-9.3.0.tgz", + "integrity": "sha512-hv95iU5uXPbK83mjrJKuZyFM/LBAoCV/XhVGkS5Je6tl7sxr6A0ITMw5WoRV46/UaJ46Nllm3Xt7IaJhXTIkzw==" }, "commondir": { "version": "1.0.1", @@ -4859,9 +4881,9 @@ } }, "core-js": { - "version": "3.22.7", - "resolved": "https://registry.npmjs.org/core-js/-/core-js-3.22.7.tgz", - "integrity": "sha512-Jt8SReuDKVNZnZEzyEQT5eK6T2RRCXkfTq7Lo09kpm+fHjgGewSbNjV+Wt4yZMhPDdzz2x1ulI5z/w4nxpBseg==" + "version": "3.22.8", + "resolved": "https://registry.npmjs.org/core-js/-/core-js-3.22.8.tgz", + "integrity": "sha512-UoGQ/cfzGYIuiq6Z7vWL1HfkE9U9IZ4Ub+0XSiJTCzvbZzgPA69oDF2f+lgJ6dFFLEdjW5O6svvoKzXX23xFkA==" }, "core-js-compat": { "version": "3.22.7", @@ -4930,13 +4952,13 @@ } }, "cosmiconfig-typescript-loader": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/cosmiconfig-typescript-loader/-/cosmiconfig-typescript-loader-2.0.0.tgz", - "integrity": "sha512-2NlGul/E3vTQEANqPziqkA01vfiuUU8vT0jZAuUIjEW8u3eCcnCQWLggapCjhbF76s7KQF0fM0kXSKmzaDaG1g==", + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/cosmiconfig-typescript-loader/-/cosmiconfig-typescript-loader-2.0.1.tgz", + "integrity": "sha512-B9s6sX/omXq7I6gC6+YgLmrBFMJhPWew7ty/X5Tuwtd2zOSgWaUdXjkuVwbe3qqcdETo60+1nSVMekq//LIXVA==", "dev": true, "requires": { "cosmiconfig": "^7", - "ts-node": "^10.7.0" + "ts-node": "^10.8.0" } }, "create-require": { @@ -5042,9 +5064,9 @@ "integrity": "sha1-QuJ9T6BK4y+TGktNQZH6nN3ul8s=" }, "cssdb": { - "version": "6.6.2", - "resolved": "https://registry.npmjs.org/cssdb/-/cssdb-6.6.2.tgz", - "integrity": "sha512-w08LaP+DRoPlw4g4LSUp+EWRrWTPlrzWREcU7/6IeMfL7tPR2P9oeQ1G+pxyfMmLWBNDwqHWa6kxiuGMLb71EA==", + "version": "6.6.3", + "resolved": "https://registry.npmjs.org/cssdb/-/cssdb-6.6.3.tgz", + "integrity": "sha512-7GDvDSmE+20+WcSMhP17Q1EVWUrLlbxxpMDqG731n8P99JhnQZHR9YvtjPvEHfjFUjvQJvdpKCjlKOX+xe4UVA==", "dev": true }, "cssesc": { @@ -5529,7 +5551,7 @@ "duplexer3": { "version": "0.1.4", "resolved": "https://registry.npmjs.org/duplexer3/-/duplexer3-0.1.4.tgz", - "integrity": "sha1-7gHdHKwO08vH/b6jfcCo8c4ALOI=" + "integrity": "sha512-CEj8FwwNA4cVH2uFCoHUrmojhYh1vmCdOaneKJXwkeY1i9jnlslVo9dx+hQ5Hl9GnH/Bwy/IjxAyOePyPKYnzA==" }, "eastasianwidth": { "version": "0.2.0", @@ -5733,9 +5755,9 @@ "dev": true }, "eslint": { - "version": "8.16.0", - "resolved": "https://registry.npmjs.org/eslint/-/eslint-8.16.0.tgz", - "integrity": "sha512-MBndsoXY/PeVTDJeWsYj7kLZ5hQpJOfMYLsF6LicLHQWbRDG19lK5jOix4DPl8yY4SUFcE3txy86OzFLWT+yoA==", + "version": "8.17.0", + "resolved": "https://registry.npmjs.org/eslint/-/eslint-8.17.0.tgz", + "integrity": "sha512-gq0m0BTJfci60Fz4nczYxNAlED+sMcihltndR8t9t1evnU/azx53x3t2UHXC/uRjcbvRw/XctpaNygSTcQD+Iw==", "dev": true, "requires": { "@eslint/eslintrc": "^1.3.0", @@ -6020,7 +6042,7 @@ "fast-levenshtein": { "version": "2.0.6", "resolved": "https://registry.npmjs.org/fast-levenshtein/-/fast-levenshtein-2.0.6.tgz", - "integrity": "sha1-PYpcZog6FqMMqGQ+hR8Zuqd5eRc=", + "integrity": "sha512-DCXu6Ifhqcks7TZKY3Hxp3y6qphY5SJZmrWMDrKcERSOXWQdMhU9Ig/PYrzyw/ul9jOIyh0N4M0tbC5hodg8dw==", "dev": true }, "fast-memoize": { @@ -6318,7 +6340,7 @@ "functional-red-black-tree": { "version": "1.0.1", "resolved": "https://registry.npmjs.org/functional-red-black-tree/-/functional-red-black-tree-1.0.1.tgz", - "integrity": "sha1-GwqzvVU7Kg1jmdKcDj6gslIHgyc=", + "integrity": "sha512-dsKNQNdj6xA3T+QlADDA7mOSlX0qiMINjn0cgr+eGHGsbSHzTabcIogz2+p/iqP1Xs6EP/sS2SbqH+brGTbq0g==", "dev": true }, "gauge": { @@ -6708,7 +6730,7 @@ "has-unicode": { "version": "2.0.1", "resolved": "https://registry.npmjs.org/has-unicode/-/has-unicode-2.0.1.tgz", - "integrity": "sha1-4Ob+aijPUROIVeCG0Wkedx3iqLk=" + "integrity": "sha512-8Rf9Y83NBReMnx0gFzA8JImQACstCYWUplepDa9xprwwtmgEZUF0h/i5xSA625zB/I37EtrswSST6OXxwaaIJQ==" }, "has-yarn": { "version": "2.1.0", @@ -6863,7 +6885,7 @@ "humanize-ms": { "version": "1.2.1", "resolved": "https://registry.npmjs.org/humanize-ms/-/humanize-ms-1.2.1.tgz", - "integrity": "sha1-xG4xWaKT9riW2ikxbYtv6Lt5u+0=", + "integrity": "sha512-Fl70vYtsAFb/C06PTS9dZBo7ihau+Tu/DNCk/OyHhea07S+aeMWpFFkUaXRa8fI+ScZbEI8dfSxwY7gxZ9SAVQ==", "requires": { "ms": "^2.0.0" } @@ -6929,7 +6951,7 @@ "import-lazy": { "version": "2.1.0", "resolved": "https://registry.npmjs.org/import-lazy/-/import-lazy-2.1.0.tgz", - "integrity": "sha1-BWmOPUXIjo1+nZLLBYTnfwlvPkM=" + "integrity": "sha512-m7ZEHgtw69qOGw+jwxXkHlrlIPdTGkyh66zXZ1ajZbxkDBNjSY/LGbmjc7h0s2ELsUDTAhFr55TrPSSqJGPG0A==" }, "import-local": { "version": "3.1.0", @@ -6944,7 +6966,7 @@ "imurmurhash": { "version": "0.1.4", "resolved": "https://registry.npmjs.org/imurmurhash/-/imurmurhash-0.1.4.tgz", - "integrity": "sha1-khi5srkoojixPcT7a21XbyMUU+o=" + "integrity": "sha512-JmXMZ6wuvDmLiHEml9ykzqO6lwFbof0GG4IkcGaENdCRDDmMVnny7s5HsIgHCbaq0w2MyPhDqkhTUgS2LU2PHA==" }, "indent-string": { "version": "4.0.0", @@ -7107,7 +7129,7 @@ "is-lambda": { "version": "1.0.1", "resolved": "https://registry.npmjs.org/is-lambda/-/is-lambda-1.0.1.tgz", - "integrity": "sha1-PZh3iZ5qU+/AFgUEzeFfgubwYdU=" + "integrity": "sha512-z7CMFGNrENq5iFB9Bqo64Xk6Y9sg+epq1myIcdHaGnbMTYOxvzsEtdYqQUylB7LxfkvgrrjP32T6Ywciio9UIQ==" }, "is-negative-zero": { "version": "2.0.2", @@ -7316,7 +7338,7 @@ "jju": { "version": "1.4.0", "resolved": "https://registry.npmjs.org/jju/-/jju-1.4.0.tgz", - "integrity": "sha1-o6vicYryQaKykE+EpiWXDzia4yo=" + "integrity": "sha512-8wb9Yw966OSxApiCt0K3yNJL8pnNeIv+OEq2YMidz4FKP6nonSRoOXc80iXY4JaN2FC11B9qsNmDsm+ZOfMROA==" }, "js-cookie": { "version": "3.0.1", @@ -7352,7 +7374,7 @@ "json-buffer": { "version": "3.0.0", "resolved": "https://registry.npmjs.org/json-buffer/-/json-buffer-3.0.0.tgz", - "integrity": "sha1-Wx85evx11ne96Lz8Dkfh+aPZqJg=" + "integrity": "sha512-CuUqjv0FUZIdXkHPI8MezCnFCdaTAacej1TZYulLoAg1h/PhwkdXFN4V/gzY4g+fMBCOV2xF+rp7t2XD2ns/NQ==" }, "json-parse-better-errors": { "version": "1.0.2", @@ -7368,7 +7390,7 @@ "json-parse-helpfulerror": { "version": "1.0.3", "resolved": "https://registry.npmjs.org/json-parse-helpfulerror/-/json-parse-helpfulerror-1.0.3.tgz", - "integrity": "sha1-E/FM4C7tTpgSl7ZOueO5MuLdE9w=", + "integrity": "sha512-XgP0FGR77+QhUxjXkwOMkC94k3WtqEBfcnjWqhRd82qTat4SWKRE+9kUnynz/shm3I4ea2+qISvTIeGTNU7kJg==", "requires": { "jju": "^1.1.0" } @@ -7388,7 +7410,7 @@ "json-stable-stringify-without-jsonify": { "version": "1.0.1", "resolved": "https://registry.npmjs.org/json-stable-stringify-without-jsonify/-/json-stable-stringify-without-jsonify-1.0.1.tgz", - "integrity": "sha1-nbe1lJatPzz+8wp1FC0tkwrXJlE=", + "integrity": "sha512-Bdboy+l7tA3OGW6FjyFHWkP5LuByj1Tk33Ljyq0axyzdk9//JSi2u3fP1QSmd1KNwq6VOKYGlAu87CisVir6Pw==", "dev": true }, "json-stringify-safe": { @@ -7415,7 +7437,7 @@ "jsonlines": { "version": "0.1.1", "resolved": "https://registry.npmjs.org/jsonlines/-/jsonlines-0.1.1.tgz", - "integrity": "sha1-T80kbcXQ44aRkHxEqwAveC0dlMw=" + "integrity": "sha512-ekDrAGso79Cvf+dtm+mL8OBI2bmAOt3gssYs833De/C9NmIpWDWyUO4zPgB5x2/OhY366dkhgfPMYfwZF7yOZA==" }, "jsonparse": { "version": "1.3.1", @@ -7765,37 +7787,113 @@ "dev": true }, "lint-staged": { - "version": "12.4.2", - "resolved": "https://registry.npmjs.org/lint-staged/-/lint-staged-12.4.2.tgz", - "integrity": "sha512-JAJGIzY/OioIUtrRePr8go6qUxij//mL+RGGoFKU3VWQRtIHgWoHizSqH0QVn2OwrbXS9Q6CICQjfj+E5qvrXg==", + "version": "13.0.0", + "resolved": "https://registry.npmjs.org/lint-staged/-/lint-staged-13.0.0.tgz", + "integrity": "sha512-vWban5utFt78VZohbosUxNIa46KKJ+KOQTDWTQ8oSl1DLEEVl9zhUtaQbiiydAmx+h2wKJK2d0+iMaRmknuWRQ==", "dev": true, "requires": { "cli-truncate": "^3.1.0", "colorette": "^2.0.16", - "commander": "^8.3.0", - "debug": "^4.3.3", - "execa": "^5.1.1", - "lilconfig": "2.0.4", - "listr2": "^4.0.1", - "micromatch": "^4.0.4", + "commander": "^9.3.0", + "debug": "^4.3.4", + "execa": "^6.1.0", + "lilconfig": "2.0.5", + "listr2": "^4.0.5", + "micromatch": "^4.0.5", "normalize-path": "^3.0.0", - "object-inspect": "^1.12.0", + "object-inspect": "^1.12.2", "pidtree": "^0.5.0", "string-argv": "^0.3.1", - "supports-color": "^9.2.1", - "yaml": "^1.10.2" + "yaml": "^2.1.1" }, "dependencies": { - "commander": { - "version": "8.3.0", - "resolved": "https://registry.npmjs.org/commander/-/commander-8.3.0.tgz", - "integrity": "sha512-OkTL9umf+He2DZkUq8f8J9of7yL6RJKI24dVITBmNfZBmri9zYZQrKkuXiKhyfPSu8tUhnVBB1iKXevvnlR4Ww==", + "execa": { + "version": "6.1.0", + "resolved": "https://registry.npmjs.org/execa/-/execa-6.1.0.tgz", + "integrity": "sha512-QVWlX2e50heYJcCPG0iWtf8r0xjEYfz/OYLGDYH+IyjWezzPNxz63qNFOu0l4YftGWuizFVZHHs8PrLU5p2IDA==", + "dev": true, + "requires": { + "cross-spawn": "^7.0.3", + "get-stream": "^6.0.1", + "human-signals": "^3.0.1", + "is-stream": "^3.0.0", + "merge-stream": "^2.0.0", + "npm-run-path": "^5.1.0", + "onetime": "^6.0.0", + "signal-exit": "^3.0.7", + "strip-final-newline": "^3.0.0" + } + }, + "get-stream": { + "version": "6.0.1", + "resolved": "https://registry.npmjs.org/get-stream/-/get-stream-6.0.1.tgz", + "integrity": "sha512-ts6Wi+2j3jQjqi70w5AlN8DFnkSwC+MqmxEzdEALB2qXZYV3X/b1CTfgPLGJNMeAWxdPfU8FO1ms3NUfaHCPYg==", "dev": true }, - "supports-color": { - "version": "9.2.2", - "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-9.2.2.tgz", - "integrity": "sha512-XC6g/Kgux+rJXmwokjm9ECpD6k/smUoS5LKlUCcsYr4IY3rW0XyAympon2RmxGrlnZURMpg5T18gWDP9CsHXFA==", + "human-signals": { + "version": "3.0.1", + "resolved": "https://registry.npmjs.org/human-signals/-/human-signals-3.0.1.tgz", + "integrity": "sha512-rQLskxnM/5OCldHo+wNXbpVgDn5A17CUoKX+7Sokwaknlq7CdSnphy0W39GU8dw59XiCXmFXDg4fRuckQRKewQ==", + "dev": true + }, + "is-stream": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/is-stream/-/is-stream-3.0.0.tgz", + "integrity": "sha512-LnQR4bZ9IADDRSkvpqMGvt/tEJWclzklNgSw48V5EAaAeDd6qGvN8ei6k5p0tvxSR171VmGyHuTiAOfxAbr8kA==", + "dev": true + }, + "lilconfig": { + "version": "2.0.5", + "resolved": "https://registry.npmjs.org/lilconfig/-/lilconfig-2.0.5.tgz", + "integrity": "sha512-xaYmXZtTHPAw5m+xLN8ab9C+3a8YmV3asNSPOATITbtwrfbwaLJj8h66H1WMIpALCkqsIzK3h7oQ+PdX+LQ9Eg==", + "dev": true + }, + "mimic-fn": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/mimic-fn/-/mimic-fn-4.0.0.tgz", + "integrity": "sha512-vqiC06CuhBTUdZH+RYl8sFrL096vA45Ok5ISO6sE/Mr1jRbGH4Csnhi8f3wKVl7x8mO4Au7Ir9D3Oyv1VYMFJw==", + "dev": true + }, + "npm-run-path": { + "version": "5.1.0", + "resolved": "https://registry.npmjs.org/npm-run-path/-/npm-run-path-5.1.0.tgz", + "integrity": "sha512-sJOdmRGrY2sjNTRMbSvluQqg+8X7ZK61yvzBEIDhz4f8z1TZFYABsqjjCBd/0PUNE9M6QDgHJXQkGUEm7Q+l9Q==", + "dev": true, + "requires": { + "path-key": "^4.0.0" + } + }, + "object-inspect": { + "version": "1.12.2", + "resolved": "https://registry.npmjs.org/object-inspect/-/object-inspect-1.12.2.tgz", + "integrity": "sha512-z+cPxW0QGUp0mcqcsgQyLVRDoXFQbXOwBaqyF7VIgI4TWNQsDHrBpUQslRmIfAoYWdYzs6UlKJtB2XJpTaNSpQ==", + "dev": true + }, + "onetime": { + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/onetime/-/onetime-6.0.0.tgz", + "integrity": "sha512-1FlR+gjXK7X+AsAHso35MnyN5KqGwJRi/31ft6x0M194ht7S+rWAvd7PHss9xSKMzE0asv1pyIHaJYq+BbacAQ==", + "dev": true, + "requires": { + "mimic-fn": "^4.0.0" + } + }, + "path-key": { + "version": "4.0.0", + "resolved": "https://registry.npmjs.org/path-key/-/path-key-4.0.0.tgz", + "integrity": "sha512-haREypq7xkM7ErfgIyA0z+Bj4AGKlMSdlQE2jvJo6huWD1EdkKYV+G/T4nq0YEF2vgTT8kqMFKo1uHn950r4SQ==", + "dev": true + }, + "strip-final-newline": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/strip-final-newline/-/strip-final-newline-3.0.0.tgz", + "integrity": "sha512-dOESqjYr96iWYylGObzd39EuNTa5VJxyvVAEm5Jnh7KGo75V43Hk1odPQkNDyXNmUR6k+gEiDVXnjB8HJ3crXw==", + "dev": true + }, + "yaml": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/yaml/-/yaml-2.1.1.tgz", + "integrity": "sha512-o96x3OPo8GjWeSLF+wOAbrPfhFOGY0W00GNaxCDv+9hkcDJEnev1yh8S7pgHF0ik6zc8sQLuL8hjHjJULZp8bw==", "dev": true } } @@ -8658,7 +8756,7 @@ "natural-compare": { "version": "1.4.0", "resolved": "https://registry.npmjs.org/natural-compare/-/natural-compare-1.4.0.tgz", - "integrity": "sha1-Sr6/7tdUHywnrPspvbvRXI1bpPc=", + "integrity": "sha512-OWND8ei3VtNC9h7V60qff3SVobHr996CTwgxubgyQYEpg290h9J0buyECNNJexkFm5sOajh5G116RYA1c8ZMSw==", "dev": true }, "negotiator": { @@ -8820,9 +8918,9 @@ "integrity": "sha512-9UZCFRHQdNrfTpGg8+1INIg93B6zE0aXMVFkw1WFwvO4SlZywU6aLg5Of0Ap/PgcbSw4LNxvMWXMeugwMCX0AA==" }, "npm": { - "version": "8.11.0", - "resolved": "https://registry.npmjs.org/npm/-/npm-8.11.0.tgz", - "integrity": "sha512-4qmtwHa28J4SPmwCNoQI07KIF/ljmBhhuqG+xNXsIIRpwdKB5OXkMIGfH6KlThR6kzusxlkgR7t1haFDB88dcQ==", + "version": "8.12.1", + "resolved": "https://registry.npmjs.org/npm/-/npm-8.12.1.tgz", + "integrity": "sha512-0yOlhfgu1UzP6UijnaFuIS2bES2H9D90EA5OVsf2iOZw7VBrjntXKEwKfCaFA6vMVWkCP8qnPwCxxPdnDVwlNw==", "requires": { "@isaacs/string-locale-compare": "^1.1.0", "@npmcli/arborist": "^5.0.4", @@ -8859,7 +8957,7 @@ "libnpmsearch": "^5.0.2", "libnpmteam": "^4.0.2", "libnpmversion": "^3.0.1", - "make-fetch-happen": "^10.1.5", + "make-fetch-happen": "^10.1.6", "minipass": "^3.1.6", "minipass-pipeline": "^1.2.4", "mkdirp": "^1.0.4", @@ -8876,7 +8974,7 @@ "npm-user-validate": "^1.0.1", "npmlog": "^6.0.2", "opener": "^1.5.2", - "pacote": "^13.4.1", + "pacote": "^13.6.0", "parse-conflict-json": "^2.0.2", "proc-log": "^2.0.1", "qrcode-terminal": "^0.12.0", @@ -8910,7 +9008,7 @@ "bundled": true }, "@npmcli/arborist": { - "version": "5.2.0", + "version": "5.2.1", "bundled": true, "requires": { "@isaacs/string-locale-compare": "^1.1.0", @@ -9369,15 +9467,14 @@ } }, "glob": { - "version": "8.0.1", + "version": "8.0.3", "bundled": true, "requires": { "fs.realpath": "^1.0.0", "inflight": "^1.0.4", "inherits": "2", "minimatch": "^5.0.1", - "once": "^1.3.0", - "path-is-absolute": "^1.0.0" + "once": "^1.3.0" } }, "graceful-fs": { @@ -9569,7 +9666,7 @@ } }, "libnpmexec": { - "version": "4.0.5", + "version": "4.0.6", "bundled": true, "requires": { "@npmcli/arborist": "^5.0.0", @@ -9660,7 +9757,7 @@ "bundled": true }, "make-fetch-happen": { - "version": "10.1.5", + "version": "10.1.6", "bundled": true, "requires": { "agentkeepalive": "^4.2.1", @@ -9682,7 +9779,7 @@ } }, "minimatch": { - "version": "5.0.1", + "version": "5.1.0", "bundled": true, "requires": { "brace-expansion": "^2.0.1" @@ -9799,13 +9896,13 @@ } }, "glob": { - "version": "7.2.0", + "version": "7.2.3", "bundled": true, "requires": { "fs.realpath": "^1.0.0", "inflight": "^1.0.4", "inherits": "2", - "minimatch": "^3.0.4", + "minimatch": "^3.1.1", "once": "^1.3.0", "path-is-absolute": "^1.0.0" } @@ -9944,7 +10041,7 @@ } }, "pacote": { - "version": "13.5.0", + "version": "13.6.0", "bundled": true, "requires": { "@npmcli/git": "^3.0.0", @@ -10086,13 +10183,13 @@ } }, "glob": { - "version": "7.2.0", + "version": "7.2.3", "bundled": true, "requires": { "fs.realpath": "^1.0.0", "inflight": "^1.0.4", "inherits": "2", - "minimatch": "^3.0.4", + "minimatch": "^3.1.1", "once": "^1.3.0", "path-is-absolute": "^1.0.0" } @@ -10330,14 +10427,14 @@ } }, "npm-check-updates": { - "version": "13.0.3", - "resolved": "https://registry.npmjs.org/npm-check-updates/-/npm-check-updates-13.0.3.tgz", - "integrity": "sha512-a8CVklJjXZhmN5Kup8rKiejArobCbOaMnubhvM/LkYVumO17dBuWuaHUuiSrYglQUb88lGSdbNNfHDNN7b+3pQ==", + "version": "13.1.1", + "resolved": "https://registry.npmjs.org/npm-check-updates/-/npm-check-updates-13.1.1.tgz", + "integrity": "sha512-f4gLbUJJh5qvkNvrSG3b05y3ZvyZ4Sl3Uk95DSyCjIWwpwmAwzU9dMCA/Gg2AmIKqkH4ml6X9kxcZsu+tAd94g==", "requires": { "chalk": "^4.1.2", "cint": "^8.2.1", "cli-table": "^0.3.11", - "commander": "^9.2.0", + "commander": "^9.3.0", "fast-memoize": "^2.5.2", "find-up": "5.0.0", "fp-and-or": "^0.1.3", @@ -10347,9 +10444,9 @@ "json-parse-helpfulerror": "^1.0.3", "jsonlines": "^0.1.1", "lodash": "^4.17.21", - "minimatch": "^5.0.1", + "minimatch": "^5.1.0", "p-map": "^4.0.0", - "pacote": "^13.3.0", + "pacote": "^13.5.0", "parse-github-url": "^1.0.2", "progress": "^2.0.3", "prompts": "^2.4.2", @@ -10361,13 +10458,13 @@ "source-map-support": "^0.5.21", "spawn-please": "^1.0.0", "update-notifier": "^5.1.0", - "yaml": "^2.1.0" + "yaml": "^2.1.1" }, "dependencies": { "yaml": { - "version": "2.1.0", - "resolved": "https://registry.npmjs.org/yaml/-/yaml-2.1.0.tgz", - "integrity": "sha512-OuAINfTsoJrY5H7CBWnKZhX6nZciXBydrMtTHr1dC4nP40X5jyTIVlogZHxSlVZM8zSgXRfgZGsaHF4+pV+JRw==" + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/yaml/-/yaml-2.1.1.tgz", + "integrity": "sha512-o96x3OPo8GjWeSLF+wOAbrPfhFOGY0W00GNaxCDv+9hkcDJEnev1yh8S7pgHF0ik6zc8sQLuL8hjHjJULZp8bw==" } } }, @@ -10446,9 +10543,9 @@ } }, "make-fetch-happen": { - "version": "10.1.6", - "resolved": "https://registry.npmjs.org/make-fetch-happen/-/make-fetch-happen-10.1.6.tgz", - "integrity": "sha512-/iKDlRQF0fkxyB/w/duW2yRYrGwBcbJjC37ijgi0CmOZ32bzMc86BCSSAHWvuyRFCB408iBPziTSzazBSrKo3w==", + "version": "10.1.7", + "resolved": "https://registry.npmjs.org/make-fetch-happen/-/make-fetch-happen-10.1.7.tgz", + "integrity": "sha512-J/2xa2+7zlIUKqfyXDCXFpH3ypxO4k3rgkZHPSZkyUYcBT/hM80M3oyKLM/9dVriZFiGeGGS2Ei+0v2zfhqj3Q==", "requires": { "agentkeepalive": "^4.2.1", "cacache": "^16.1.0", @@ -10464,7 +10561,7 @@ "minipass-pipeline": "^1.2.4", "negotiator": "^0.6.3", "promise-retry": "^2.0.1", - "socks-proxy-agent": "^6.1.1", + "socks-proxy-agent": "^7.0.0", "ssri": "^9.0.0" } }, @@ -10478,6 +10575,16 @@ "minipass-sized": "^1.0.3", "minizlib": "^2.1.2" } + }, + "socks-proxy-agent": { + "version": "7.0.0", + "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-7.0.0.tgz", + "integrity": "sha512-Fgl0YPZ902wEsAyiQ+idGd1A7rSFx/ayC1CQVMw5P+EQx2V0SgpGtf6OKFhVjPflPUl9YMmEOnmfjCdMUsygww==", + "requires": { + "agent-base": "^6.0.2", + "debug": "^4.3.3", + "socks": "^2.6.2" + } } } }, @@ -10873,9 +10980,9 @@ } }, "pacote": { - "version": "13.5.0", - "resolved": "https://registry.npmjs.org/pacote/-/pacote-13.5.0.tgz", - "integrity": "sha512-yekp0ykEsaBH0t0bYA/89R+ywdYV5ZnEdg4YMIfqakSlpIhoF6b8+aEUm8NZpfWRgmy6lxgywcW05URhLRogVQ==", + "version": "13.6.0", + "resolved": "https://registry.npmjs.org/pacote/-/pacote-13.6.0.tgz", + "integrity": "sha512-zHmuCwG4+QKnj47LFlW3LmArwKoglx2k5xtADiMCivVWPgNRP5QyLDGOIjGjwOe61lhl1rO63m/VxT16pEHLWg==", "requires": { "@npmcli/git": "^3.0.0", "@npmcli/installed-package-contents": "^1.0.7", @@ -11089,12 +11196,12 @@ } }, "postcss-attribute-case-insensitive": { - "version": "5.0.0", - "resolved": "https://registry.npmjs.org/postcss-attribute-case-insensitive/-/postcss-attribute-case-insensitive-5.0.0.tgz", - "integrity": "sha512-b4g9eagFGq9T5SWX4+USfVyjIb3liPnjhHHRMP7FMB2kFVpYyfEscV0wP3eaXhKlcHKUut8lt5BGoeylWA/dBQ==", + "version": "5.0.1", + "resolved": "https://registry.npmjs.org/postcss-attribute-case-insensitive/-/postcss-attribute-case-insensitive-5.0.1.tgz", + "integrity": "sha512-wrt2VndqSLJpyBRNz9OmJcgnhI9MaongeWgapdBuUMu2a/KNJ8SENesG4SdiTnQwGO9b1VKbTWYAfCPeokLqZQ==", "dev": true, "requires": { - "postcss-selector-parser": "^6.0.2" + "postcss-selector-parser": "^6.0.10" } }, "postcss-calc": { @@ -11165,9 +11272,9 @@ } }, "postcss-custom-media": { - "version": "8.0.0", - "resolved": "https://registry.npmjs.org/postcss-custom-media/-/postcss-custom-media-8.0.0.tgz", - "integrity": "sha512-FvO2GzMUaTN0t1fBULDeIvxr5IvbDXcIatt6pnJghc736nqNgsGao5NT+5+WVLAQiTt6Cb3YUms0jiPaXhL//g==", + "version": "8.0.1", + "resolved": "https://registry.npmjs.org/postcss-custom-media/-/postcss-custom-media-8.0.1.tgz", + "integrity": "sha512-ZhBAYOOOeEV9eosUARv67HAhwM3PsKaWDxXs31usUoBd78VUiXZGgtbvGM1IFWgTaW2S5oYOJ2iD4dwSdHzfiQ==", "dev": true }, "postcss-custom-properties": { @@ -11180,9 +11287,9 @@ } }, "postcss-custom-selectors": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/postcss-custom-selectors/-/postcss-custom-selectors-6.0.0.tgz", - "integrity": "sha512-/1iyBhz/W8jUepjGyu7V1OPcGbc636snN1yXEQCinb6Bwt7KxsiU7/bLQlp8GwAXzCh7cobBU5odNn/2zQWR8Q==", + "version": "6.0.2", + "resolved": "https://registry.npmjs.org/postcss-custom-selectors/-/postcss-custom-selectors-6.0.2.tgz", + "integrity": "sha512-vGkvyy7js/OPLdeJUCh+iH7xA2+w0lK4ecahUoCaZaDblQXZ9ADrLG4TNI0lNYrJWwe9k/jyLhliIoUs/og3SQ==", "dev": true, "requires": { "postcss-selector-parser": "^6.0.4" @@ -11551,12 +11658,12 @@ } }, "postcss-preset-env": { - "version": "7.6.0", - "resolved": "https://registry.npmjs.org/postcss-preset-env/-/postcss-preset-env-7.6.0.tgz", - "integrity": "sha512-5cnzpSFZnQJOlBu85xn4Nnluy/WjIST/ugn+gOVcKnmFJ+GLtkfRhmJPo/TW9UDpG7oyA467kvDOO8mtcpOL4g==", + "version": "7.7.1", + "resolved": "https://registry.npmjs.org/postcss-preset-env/-/postcss-preset-env-7.7.1.tgz", + "integrity": "sha512-1sx6+Nl1wMVJzaYLVaz4OAR6JodIN/Z1upmVqLwSPCLT6XyxrEoePgNMHPH08kseLe3z06i9Vfkt/32BYEKDeA==", "dev": true, "requires": { - "@csstools/postcss-cascade-layers": "^1.0.1", + "@csstools/postcss-cascade-layers": "^1.0.2", "@csstools/postcss-color-function": "^1.1.0", "@csstools/postcss-font-format-keywords": "^1.0.0", "@csstools/postcss-hwb-function": "^1.0.1", @@ -11566,21 +11673,22 @@ "@csstools/postcss-oklab-function": "^1.1.0", "@csstools/postcss-progressive-custom-properties": "^1.3.0", "@csstools/postcss-stepped-value-functions": "^1.0.0", + "@csstools/postcss-trigonometric-functions": "^1.0.1", "@csstools/postcss-unset-value": "^1.0.1", "autoprefixer": "^10.4.7", "browserslist": "^4.20.3", "css-blank-pseudo": "^3.0.3", "css-has-pseudo": "^3.0.4", "css-prefers-color-scheme": "^6.0.3", - "cssdb": "^6.6.1", - "postcss-attribute-case-insensitive": "^5.0.0", + "cssdb": "^6.6.3", + "postcss-attribute-case-insensitive": "^5.0.1", "postcss-clamp": "^4.1.0", - "postcss-color-functional-notation": "^4.2.2", + "postcss-color-functional-notation": "^4.2.3", "postcss-color-hex-alpha": "^8.0.3", "postcss-color-rebeccapurple": "^7.0.2", - "postcss-custom-media": "^8.0.0", + "postcss-custom-media": "^8.0.1", "postcss-custom-properties": "^12.1.7", - "postcss-custom-selectors": "^6.0.0", + "postcss-custom-selectors": "^6.0.2", "postcss-dir-pseudo-class": "^6.0.4", "postcss-double-position-gradients": "^3.1.1", "postcss-env-function": "^4.0.6", @@ -11593,14 +11701,14 @@ "postcss-lab-function": "^4.2.0", "postcss-logical": "^5.0.4", "postcss-media-minmax": "^5.0.0", - "postcss-nesting": "^10.1.6", + "postcss-nesting": "^10.1.7", "postcss-opacity-percentage": "^1.1.2", "postcss-overflow-shorthand": "^3.0.3", "postcss-page-break": "^3.0.4", "postcss-place": "^7.0.4", "postcss-pseudo-class-any-link": "^7.1.4", "postcss-replace-overflow-wrap": "^4.0.0", - "postcss-selector-not": "^5.0.0", + "postcss-selector-not": "^6.0.0", "postcss-value-parser": "^4.2.0" }, "dependencies": { @@ -11618,9 +11726,9 @@ } }, "electron-to-chromium": { - "version": "1.4.141", - "resolved": "https://registry.npmjs.org/electron-to-chromium/-/electron-to-chromium-1.4.141.tgz", - "integrity": "sha512-mfBcbqc0qc6RlxrsIgLG2wCqkiPAjEezHxGTu7p3dHHFOurH4EjS9rFZndX5axC8264rI1Pcbw8uQP39oZckeA==", + "version": "1.4.146", + "resolved": "https://registry.npmjs.org/electron-to-chromium/-/electron-to-chromium-1.4.146.tgz", + "integrity": "sha512-4eWebzDLd+hYLm4csbyMU2EbBnqhwl8Oe9eF/7CBDPWcRxFmqzx4izxvHH+lofQxzieg8UbB8ZuzNTxeukzfTg==", "dev": true } } @@ -11660,12 +11768,12 @@ "dev": true }, "postcss-selector-not": { - "version": "5.0.0", - "resolved": "https://registry.npmjs.org/postcss-selector-not/-/postcss-selector-not-5.0.0.tgz", - "integrity": "sha512-/2K3A4TCP9orP4TNS7u3tGdRFVKqz/E6pX3aGnriPG0jU78of8wsUcqE4QAhWEU0d+WnMSF93Ah3F//vUtK+iQ==", + "version": "6.0.0", + "resolved": "https://registry.npmjs.org/postcss-selector-not/-/postcss-selector-not-6.0.0.tgz", + "integrity": "sha512-i/HI/VNd3V9e1WOLCwJsf9nePBRXqcGtVibcJ9FsVo0agfDEfsLSlFt94aYjY35wUNcdG0KrvdyjEr7It50wLQ==", "dev": true, "requires": { - "balanced-match": "^1.0.0" + "postcss-selector-parser": "^6.0.10" } }, "postcss-selector-parser": { @@ -11712,7 +11820,7 @@ "prepend-http": { "version": "2.0.0", "resolved": "https://registry.npmjs.org/prepend-http/-/prepend-http-2.0.0.tgz", - "integrity": "sha1-6SQ0v6XqjBn0HN/UAddBo8gZ2Jc=" + "integrity": "sha512-ravE6m9Atw9Z/jjttRUZ+clIXogdghyZAuWJ3qEzjT+jI/dL1ifAqhZeC5VHzQp1MSt1+jxKkFNemj/iO7tVUA==" }, "pretty-error": { "version": "4.0.0", @@ -11749,7 +11857,7 @@ "promise-inflight": { "version": "1.0.1", "resolved": "https://registry.npmjs.org/promise-inflight/-/promise-inflight-1.0.1.tgz", - "integrity": "sha1-mEcocL8igTL8vdhoEputEsPAKeM=" + "integrity": "sha512-6zWPyEOFaQBJYcGMHBKTKJ3u6TBsnMFOIZSa6ce1e/ZrrsOlnHRHbabMjLiBYKp+n44X9eUI6VUPaukCXHuG4g==" }, "promise-retry": { "version": "2.0.1", @@ -12383,7 +12491,7 @@ "global-dirs": { "version": "0.1.1", "resolved": "https://registry.npmjs.org/global-dirs/-/global-dirs-0.1.1.tgz", - "integrity": "sha1-sxnA3UYH81PzvpzKTHL8FIxJ9EU=", + "integrity": "sha512-NknMLn7F2J7aflwFOlGdNIuCDpN3VGoSoB+aap3KABFWbHVn1TCgFC+np23J8W2BiZbjfEw3BFBycSMv1AFblg==", "dev": true, "requires": { "ini": "^1.3.4" @@ -12536,9 +12644,9 @@ "integrity": "sha512-YZo3K82SD7Riyi0E1EQPojLz7kpepnSQI9IyPbHHg1XXXevb5dJI7tpyN2ADxGcQbHG7vcyRHk0cbwqcQriUtg==" }, "sass": { - "version": "1.52.1", - "resolved": "https://registry.npmjs.org/sass/-/sass-1.52.1.tgz", - "integrity": "sha512-fSzYTbr7z8oQnVJ3Acp9hV80dM1fkMN7mSD/25mpcct9F7FPBMOI8krEYALgU1aZoqGhQNhTPsuSmxjnIvAm4Q==", + "version": "1.52.2", + "resolved": "https://registry.npmjs.org/sass/-/sass-1.52.2.tgz", + "integrity": "sha512-mfHB2VSeFS7sZlPv9YohB9GB7yWIgQNTGniQwfQ04EoQN0wsQEv7SwpCwy/x48Af+Z3vDeFXz+iuXM3HK/phZQ==", "dev": true, "requires": { "chokidar": ">=3.0.0 <4.0.0", @@ -12836,9 +12944,9 @@ } }, "socks-proxy-agent": { - "version": "6.2.0", - "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-6.2.0.tgz", - "integrity": "sha512-wWqJhjb32Q6GsrUqzuFkukxb/zzide5quXYcMVpIjxalDBBYy2nqKCFQ/9+Ie4dvOYSQdOk3hUlZSdzZOd3zMQ==", + "version": "6.2.1", + "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-6.2.1.tgz", + "integrity": "sha512-a6KW9G+6B3nWZ1yB8G7pJwL3ggLy1uTzKAgCb7ttblwqdz9fMGJUuTy3uFzEP48FAs9FLILlmzDlE2JJhVQaXQ==", "requires": { "agent-base": "^6.0.2", "debug": "^4.3.3", @@ -13288,15 +13396,15 @@ } }, "terser-webpack-plugin": { - "version": "5.3.1", - "resolved": "https://registry.npmjs.org/terser-webpack-plugin/-/terser-webpack-plugin-5.3.1.tgz", - "integrity": "sha512-GvlZdT6wPQKbDNW/GDQzZFg/j4vKU96yl2q6mcUkzKOgW4gwf1Z8cZToUCrz31XHlPWH8MVb1r2tFtdDtTGJ7g==", + "version": "5.3.3", + "resolved": "https://registry.npmjs.org/terser-webpack-plugin/-/terser-webpack-plugin-5.3.3.tgz", + "integrity": "sha512-Fx60G5HNYknNTNQnzQ1VePRuu89ZVYWfjRAeT5rITuCY/1b08s49e5kSQwHDirKZWuoKOBRFS98EUUoZ9kLEwQ==", "dev": true, "requires": { + "@jridgewell/trace-mapping": "^0.3.7", "jest-worker": "^27.4.5", "schema-utils": "^3.1.1", "serialize-javascript": "^6.0.0", - "source-map": "^0.6.1", "terser": "^5.7.2" }, "dependencies": { @@ -13531,9 +13639,9 @@ "dev": true }, "ts-node": { - "version": "10.8.0", - "resolved": "https://registry.npmjs.org/ts-node/-/ts-node-10.8.0.tgz", - "integrity": "sha512-/fNd5Qh+zTt8Vt1KbYZjRHCE9sI5i7nqfD/dzBBRDeVXZXS6kToW6R7tTU6Nd4XavFs0mAVCg29Q//ML7WsZYA==", + "version": "10.8.1", + "resolved": "https://registry.npmjs.org/ts-node/-/ts-node-10.8.1.tgz", + "integrity": "sha512-Wwsnao4DQoJsN034wePSg5nZiw4YKXf56mPIAeD6wVmiv+RytNSWqc2f3fKvcUoV+Yn2+yocD71VOfQHbmVX4g==", "dev": true, "requires": { "@cspotcode/source-map-support": "^0.8.0", @@ -13629,9 +13737,9 @@ "dev": true }, "typescript": { - "version": "4.7.2", - "resolved": "https://registry.npmjs.org/typescript/-/typescript-4.7.2.tgz", - "integrity": "sha512-Mamb1iX2FDUpcTRzltPxgWMKy3fhg0TN378ylbktPGPK/99KbDtMQ4W1hwgsbPAsG3a0xKa1vmw4VKZQbkvz5A==", + "version": "4.7.3", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-4.7.3.tgz", + "integrity": "sha512-WOkT3XYvrpXx4vMMqlD+8R8R37fZkjyLGlxavMc4iB8lrl8L0DeTcHbYgw/v0N/z9wAFsgBhcsF0ruoySS22mA==", "dev": true }, "ua-parser-js": { @@ -13860,9 +13968,9 @@ "dev": true }, "watchpack": { - "version": "2.3.1", - "resolved": "https://registry.npmjs.org/watchpack/-/watchpack-2.3.1.tgz", - "integrity": "sha512-x0t0JuydIo8qCNctdDrn1OzH/qDzk2+rdCOC3YzumZ42fiMqmQ7T3xQurykYMhYfHaPHTp4ZxAx2NfUo1K6QaA==", + "version": "2.4.0", + "resolved": "https://registry.npmjs.org/watchpack/-/watchpack-2.4.0.tgz", + "integrity": "sha512-Lcvm7MGST/4fup+ifyKi2hjyIAwcdI4HRgtvTpIUxBRhB+RFtUh8XtDOxUfctVCnhVi+QQj49i91OyvzkJl6cg==", "dev": true, "requires": { "glob-to-regexp": "^0.4.1", @@ -13870,9 +13978,9 @@ } }, "webpack": { - "version": "5.72.1", - "resolved": "https://registry.npmjs.org/webpack/-/webpack-5.72.1.tgz", - "integrity": "sha512-dXG5zXCLspQR4krZVR6QgajnZOjW2K/djHvdcRaDQvsjV9z9vaW6+ja5dZOYbqBBjF6kGXka/2ZyxNdc+8Jung==", + "version": "5.73.0", + "resolved": "https://registry.npmjs.org/webpack/-/webpack-5.73.0.tgz", + "integrity": "sha512-svjudQRPPa0YiOYa2lM/Gacw0r6PvxptHj4FuEKQ2kX05ZLkjbVc5MnPs6its5j7IZljnIqSVo/OsY2X0IpHGA==", "dev": true, "requires": { "@types/eslint-scope": "^3.7.3", diff --git a/package.json b/package.json index 0e2bdffb5..401d0cc77 100644 --- a/package.json +++ b/package.json @@ -53,8 +53,8 @@ "@babel/plugin-transform-modules-commonjs": "^7.18.2", "@babel/plugin-transform-runtime": "^7.18.2", "@babel/preset-env": "^7.18.2", - "@commitlint/cli": "^17.0.1", - "@commitlint/config-conventional": "^17.0.0", + "@commitlint/cli": "^17.0.2", + "@commitlint/config-conventional": "^17.0.2", "@fortawesome/fontawesome-pro": "^6.1.1", "autoprefixer": "^10.4.7", "babel-core": "^6.26.3", @@ -67,7 +67,7 @@ "clean-webpack-plugin": "^4.0.0", "copy-webpack-plugin": "^11.0.0", "css-loader": "^6.7.1", - "eslint": "^8.16.0", + "eslint": "^8.17.0", "file-loader": "^6.2.0", "fs-extra": "^10.1.0", "glob": "^8.0.3", @@ -82,46 +82,46 @@ "karma-jasmine-html-reporter": "^2.0.0", "karma-mocha-reporter": "^2.2.5", "karma-webpack": "^5.0.0", - "lint-staged": "^12.4.2", + "lint-staged": "^13.0.0", "lodash.debounce": "^4.0.8", "mini-css-extract-plugin": "^2.6.0", "npm-run-all": "^4.1.5", "null-loader": "^4.0.1", "optimize-css-assets-webpack-plugin": "^6.0.1", "postcss-loader": "^7.0.0", - "postcss-preset-env": "^7.6.0", + "postcss-preset-env": "^7.7.1", "real-favicon-webpack-plugin": "^0.2.3", "remove-files-webpack-plugin": "^1.5.0", "request": "^2.88.2", "request-promise": "^4.2.6", "resolve-url-loader": "^5.0.0", - "sass": "^1.52.1", + "sass": "^1.52.2", "sass-loader": "^13.0.0", "semver": "^7.3.7", "standard-version": "^9.5.0", "standard-version-updater-yaml": "^1.0.3", "style-loader": "^3.3.1", - "terser-webpack-plugin": "^5.3.1", + "terser-webpack-plugin": "^5.3.3", "tmp": "^0.2.1", "typeface-roboto": "1.1.13", "typeface-source-code-pro": "^1.1.13", "typeface-source-sans-pro": "1.1.13", - "webpack": "^5.72.1", + "webpack": "^5.73.0", "webpack-cli": "^4.9.2", "webpack-manifest-plugin": "^5.0.0" }, "dependencies": { "@babel/runtime": "^7.18.3", "@juggle/resize-observer": "^3.3.1", - "core-js": "^3.22.7", + "core-js": "^3.22.8", "css.escape": "^1.5.1", "js-cookie": "^3.0.1", "lodash.debounce": "^4.0.8", "lodash.defer": "^4.1.0", "lodash.throttle": "^4.1.1", "moment": "^2.29.3", - "npm": "^8.11.0", - "npm-check-updates": "^13.0.3", + "npm": "^8.12.1", + "npm-check-updates": "^13.1.1", "sodium-javascript": "^0.8.0", "toposort": "^2.0.2", "whatwg-fetch": "^3.6.2" diff --git a/package.yaml b/package.yaml index aae1a44d6..0bbd21220 100644 --- a/package.yaml +++ b/package.yaml @@ -4,6 +4,7 @@ dependencies: - base - yesod - yesod-core + - yesod-persistent - yesod-auth - yesod-static - yesod-form @@ -119,6 +120,7 @@ dependencies: - hsass - semigroupoids - http-types + - http-client - jose-jwt - mono-traversable - mono-traversable-keys @@ -145,6 +147,19 @@ dependencies: - rfc5051 - unidecode - pandoc + - insert-ordered-containers + - servant + - servant-server + - servant-swagger + - servant-docs + - servant-client + - servant-client-core + - servant-quickcheck + - swagger2 + - haskell-src-meta + - network-uri + - vault + - tagged - token-bucket - async - pointedlist @@ -157,11 +172,11 @@ dependencies: - fastcdc - bimap - list-t - - insert-ordered-containers - topograph - network-uri - psqueues - nonce + - semver - IntervalMap - haskell-src-meta - either @@ -331,6 +346,7 @@ tests: - quickcheck-io - network-arbitrary - lens-properties + - http-media ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" diff --git a/routes b/routes index 582658cf6..4f9e61504 100644 --- a/routes +++ b/routes @@ -103,6 +103,8 @@ /help HelpR GET POST !free +/external-apis ExternalApisR ServantApiExternalApis getServantApi + /user ProfileR GET POST !free /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free @@ -296,4 +298,8 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -!/*WellKnownFileName WellKnownR GET !free \ No newline at end of file +/api ApiDocsR GET !free +/swagger SwaggerR GET !free +/swagger.json SwaggerJsonR GET !free + +!/*WellKnownFileName WellKnownR GET !free diff --git a/src/Application.hs b/src/Application.hs index 7d02e6009..2473bb323 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -146,6 +146,10 @@ import Handler.StorageKey import Handler.Workflow import Handler.Error import Handler.Upload +import Handler.ApiDocs +import Handler.Swagger + +import ServantApi () -- YesodSubDispatch instances -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Control/Monad/Trans/Except/Instances.hs b/src/Control/Monad/Trans/Except/Instances.hs new file mode 100644 index 000000000..1bceee959 --- /dev/null +++ b/src/Control/Monad/Trans/Except/Instances.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Control.Monad.Trans.Except.Instances + () where + +import ClassyPrelude + +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) + +import Control.Arrow (left) + + +newtype UnliftIOExceptTError e = UnliftIOExceptTError { getUnliftIOExceptTError :: e } + deriving (Read, Show, Generic, Typeable) + deriving newtype (Exception) + + +instance (Exception e, MonadUnliftIO m) => MonadUnliftIO (ExceptT e m) where + withRunInIO cont = ExceptT (withRunInIO $ \runInner -> fmap (left getUnliftIOExceptTError) . try $ cont (either (throwIO . UnliftIOExceptTError) return <=< runInner . runExceptT)) diff --git a/src/CryptoID.hs b/src/CryptoID.hs index be3e30c80..72e03de8f 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -52,6 +52,7 @@ decCryptoIDs [ ''SubmissionId , ''CourseNewsId , ''CourseEventId , ''TutorialId + , ''ExternalApiId , ''ExternalExamId , ''WorkflowInstanceId , ''WorkflowWorkflowId diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index bc5a483bd..f54a38f1f 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -28,6 +28,8 @@ import Web.HttpApiData import qualified Data.Csv as Csv +import qualified Data.Swagger as Swagger + import Utils.Persist import Data.Proxy @@ -98,6 +100,8 @@ instance PathPiece [CI Char] where instance ToHttpApiData s => ToHttpApiData (CI s) where toUrlPiece = toUrlPiece . CI.original toEncodedUrlPiece = toEncodedUrlPiece . CI.original + toHeader = toHeader . CI.original + toQueryParam = toQueryParam . CI.original instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where parseUrlPiece = fmap CI.mk . parseUrlPiece @@ -112,6 +116,12 @@ instance Csv.ToField s => Csv.ToField (CI s) where instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where parseField = fmap CI.mk . Csv.parseField +instance Swagger.ToParamSchema s => Swagger.ToParamSchema (CI s) where + toParamSchema _ = Swagger.toParamSchema (Proxy @s) + +instance Swagger.ToSchema s => Swagger.ToSchema (CI s) where + declareNamedSchema _ = Swagger.declareNamedSchema (Proxy @s) + instance (CI.FoldCase s, Binary s) => Binary (CI s) where get = CI.mk <$> Binary.get put = Binary.put . CI.original diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index b48c0df70..56b4819bd 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.CryptoID.Instances @@ -5,6 +6,8 @@ module Data.CryptoID.Instances ) where import qualified Data.CryptoID as CID +import qualified Data.CryptoID.Poly as CID +import qualified Data.CryptoID.Class.ImplicitNamespace as I import Text.Blaze (ToMarkup(..)) @@ -18,6 +21,32 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..)) import qualified Data.Csv as Csv +import Data.Swagger (ToSchema, ToParamSchema) + +import Servant.Docs (ToSample(..)) + +import Control.Monad.Catch.Pure + +import Data.Proxy +import Data.Tagged + +import System.IO.Unsafe + +import Control.Lens ((??)) + + +deriving newtype instance ToParamSchema s => ToParamSchema (CID.CryptoID c s) +deriving newtype instance ToSchema s => ToSchema (CID.CryptoID c s) + +sampleKey :: CID.CryptoIDKey +sampleKey = unsafePerformIO CID.genKey +{-# NOINLINE sampleKey #-} + +instance (ToSample p, ns ~ I.CryptoIDNamespace c p, CID.HasCryptoID ns c p (ReaderT CID.CryptoIDKey Catch)) => ToSample (Tagged p (CID.CryptoID ns c)) where + toSamples _ = mapMaybe (\(l, s) -> (l, ) <$> encrypt' s) $ toSamples (Proxy @p) + where + encrypt' :: p -> Maybe (Tagged p (CID.CryptoID ns c)) + encrypt' p = either (const Nothing) (Just . Tagged) . runCatch . (runReaderT ?? sampleKey) $ I.encrypt p instance ToMarkup s => ToMarkup (CID.CryptoID c s) where toMarkup = toMarkup . CID.ciphertext diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs new file mode 100644 index 000000000..6c20a7af3 --- /dev/null +++ b/src/Data/HashSet/Instances.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.HashSet.Instances + () where + +import ClassyPrelude + +import Servant.Docs + +import qualified Data.HashSet as HashSet + +import Control.Lens +import Data.Proxy + + +instance (ToSample a, Hashable a, Eq a) => ToSample (HashSet a) where + toSamples _ = over _2 HashSet.fromList <$> toSamples (Proxy @[a]) diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs index ad472219a..76618cc4f 100644 --- a/src/Data/NonNull/Instances.hs +++ b/src/Data/NonNull/Instances.hs @@ -13,6 +13,12 @@ import qualified Data.Binary as Binary import Control.Monad.Fail +import Data.Swagger.Schema (ToSchema(..)) + +import Data.Proxy + +import Servant.Docs + instance ToJSON a => ToJSON (NonNull a) where toJSON = toJSON . toNullable @@ -20,6 +26,15 @@ instance ToJSON a => ToJSON (NonNull a) where instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable +instance ToSchema a => ToSchema (NonNull a) where + declareNamedSchema _ = declareNamedSchema $ Proxy @a + +instance (ToSample a, MonoFoldable a) => ToSample (NonNull a) where + toSamples _ = do + (l, s) <- toSamples (Proxy @a) + s' <- maybe mzero pure $ fromNullable s + return (l, s') + instance Hashable a => Hashable (NonNull a) where hashWithSalt s = hashWithSalt s . toNullable diff --git a/src/Data/SemVer/Instances.hs b/src/Data/SemVer/Instances.hs new file mode 100644 index 000000000..51d60dfb2 --- /dev/null +++ b/src/Data/SemVer/Instances.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.SemVer.Instances + () where + +import ClassyPrelude +import qualified Data.SemVer as SemVer +import qualified Data.SemVer.Constraint as SemVer (Constraint(..)) +import qualified Data.SemVer.Constraint as SemVer.Constraint + +import Web.HttpApiData + + +instance ToHttpApiData SemVer.Version where + toUrlPiece = SemVer.toText + +instance ToHttpApiData SemVer.Constraint where + toUrlPiece SemVer.CAny = "*" + toUrlPiece (SemVer.CLt v) = "<" <> toUrlPiece v + toUrlPiece (SemVer.CLtEq v) = "<=" <> toUrlPiece v + toUrlPiece (SemVer.CGt v) = ">" <> toUrlPiece v + toUrlPiece (SemVer.CGtEq v) = ">=" <> toUrlPiece v + toUrlPiece (SemVer.CEq v) = toUrlPiece v + toUrlPiece (SemVer.CAnd a b) = toUrlPiece a <> " " <> toUrlPiece b + toUrlPiece (SemVer.COr a b) = toUrlPiece a <> " || " <> toUrlPiece b + +instance FromHttpApiData SemVer.Version where + parseUrlPiece = first pack . SemVer.fromText + +instance FromHttpApiData SemVer.Constraint where + parseUrlPiece = first pack . SemVer.Constraint.fromText diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index fa152557f..37749b2b0 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -10,6 +10,7 @@ import Database.Persist.Sql import Data.Proxy import Data.Time.Clock +import Data.Time.Clock.Instances.TH () import Data.Time.Calendar.Instances () import Web.PathPieces @@ -17,6 +18,11 @@ import qualified Data.Csv as Csv import Data.Time.Format.ISO8601 +import Servant.Docs (ToSample(..), samples) + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH + instance Hashable DiffTime where hashWithSalt s = hashWithSalt s . toRational @@ -44,3 +50,11 @@ instance Csv.ToField UTCTime where instance Csv.FromField UTCTime where parseField = iso8601ParseM <=< Csv.parseField + + +instance ToSample UTCTime where + toSamples _ = samples $ do + diff <- [0,172801..] + sign <- [1, -1] + return $ (sign * diff) `addUTCTime` now + where now = $(TH.lift =<< TH.runIO getCurrentTime) diff --git a/src/Data/Time/Clock/Instances/TH.hs b/src/Data/Time/Clock/Instances/TH.hs new file mode 100644 index 000000000..4c705bf5d --- /dev/null +++ b/src/Data/Time/Clock/Instances/TH.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.Clock.Instances.TH + () where + +import ClassyPrelude + +import Data.Time.Calendar.Instances () + +import qualified Language.Haskell.TH.Syntax as TH + + +instance TH.Lift UTCTime where + liftTyped UTCTime{..} = [e||UTCTime $$(TH.liftTyped utctDay) $ fromRational $$(TH.liftTyped $ toRational utctDayTime)||] diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs index 15655fd18..88b01a446 100644 --- a/src/Data/UUID/Instances.hs +++ b/src/Data/UUID/Instances.hs @@ -13,6 +13,9 @@ import Data.Proxy import Text.Blaze (ToMarkup(..)) +import Servant.Docs (ToSample(..), samples) +import Crypto.Random + instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack @@ -38,3 +41,10 @@ instance ToMarkup UUID where instance ToWidget site UUID where toWidget = toWidget . toMarkup + +sampleNotRandom :: MonadPseudoRandom ChaChaDRG a -> a +sampleNotRandom = fst . withDRG (drgNewSeed $ seedFromInteger 0) + +instance ToSample UUID where + toSamples _ = samples $ sampleNotRandom getRandoms + where getRandoms = fmap (maybe id (:) . UUID.fromByteString . fromStrict) (getRandomBytes 16) <*> getRandoms diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 02401e3af..98044d16f 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -21,6 +21,8 @@ import Data.Aeson (ToJSONKey, FromJSONKey) import Control.Monad.Fail +import Servant.Docs (ToSample(..), samples) + instance PersistEntity record => Hashable (Key record) where hashWithSalt s = hashWithSalt s . toPersistValue @@ -40,3 +42,6 @@ instance PersistEntity record => Eq (Unique record) where deriving newtype instance ToJSONKey (BackendKey SqlBackend) deriving newtype instance FromJSONKey (BackendKey SqlBackend) + +instance ToSample (BackendKey SqlBackend) where + toSamples _ = samples [0..] diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index f18a2fb94..54f0fcecc 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -9,6 +9,7 @@ module Foundation.Authorization , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff , AuthContext(..), getAuthContext , isDryRun, isDryRunDB + , IsDryRun(..) , maybeBearerToken, requireBearerToken , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions , BearerAuthSite, MonadAP @@ -276,7 +277,9 @@ getAuthContext = liftHandler $ do return authCtx newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving stock (Read, Show, Generic, Typeable) + deriving newtype (Eq, Ord) + deriving (Semigroup, Monoid) via Any isDryRun :: ( HasCallStack , BearerAuthSite UniWorX @@ -284,17 +287,19 @@ isDryRun :: ( HasCallStack => HandlerFor UniWorX Bool isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB -isDryRunDB :: forall m backend. +isDryRunDB :: forall m backend m'. ( HasCallStack , MonadAP m, MonadCatch m + , MonadSite UniWorX m' , BearerAuthSite UniWorX - , WithRunDB backend (HandlerFor UniWorX) m + , WithRunDB backend m' m , BackendCompatible SqlReadBackend backend ) => m Bool isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM [ hasGlobalPostParam PostDryRun , hasGlobalGetParam GetDryRun + , hasCustomHeader HeaderDryRun , and2M bearerDryRun bearerRequired ] where @@ -308,7 +313,7 @@ isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar dnf <- throwLeft $ routeAuthTags currentRoute - let eval :: forall m'. MonadAP m' => AuthTagsEval m' + let eval :: forall m''. MonadAP m'' => AuthTagsEval m'' eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite @@ -1858,9 +1863,6 @@ authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem , [ AuthOwner, AuthRated ] -- Submission wide ] -defaultAuthDNF :: AuthDNF -defaultAuthDNF = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken - routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF -- ^ DNF up to entailment, see `predDNFEntail` routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 16cc1143d..764fe7fc9 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -272,12 +272,12 @@ instance YesodMail UniWorX where wait mailProcess -- Abort transaction if sending failed wait mailProcess -- Rethrow exceptions for mailprocess; technically unnecessary due to linkage, doesn't hurt, though -instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where +instance (MonadThrow m, MonadSite UniWorX m) => MonadCrypto m where type MonadCryptoKey m = CryptoIDKey - cryptoIDKey f = getsYesod appCryptoIDKey >>= f + cryptoIDKey f = getsSite appCryptoIDKey >>= f -instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where - secretBoxKey = getsYesod appSecretBoxKey +instance {-# OVERLAPPING #-} (Monad m, MonadSite UniWorX m) => MonadSecretBox m where + secretBoxKey = getsSite appSecretBoxKey instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadAuth m where authKey = getsYesod appAuthKey diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index d52d9f2c9..6a0535bd8 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -457,6 +457,12 @@ breadcrumb currentRoute@(GlobalWorkflowWorkflowR cID sRoute) = case sRoute of breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing breadcrumb (TopWorkflowWorkflowListR lType) = i18nCrumb (MsgBreadcrumbTopWorkflowWorkflowList lType) $ Just TopWorkflowInstanceListR +breadcrumb (ExternalApisR _) = i18nCrumb MsgBreadcrumbExternalApis Nothing + +breadcrumb ApiDocsR = i18nCrumb MsgBreadcrumbApiDocs Nothing +breadcrumb SwaggerR = i18nCrumb MsgBreadcrumbSwagger $ Just ApiDocsR +breadcrumb SwaggerJsonR = breadcrumb SwaggerR + data NavQuickView = NavQuickViewFavourite @@ -726,6 +732,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , return $ NavFooter NavLink + { navLabel = MsgMenuApiDocs + , navRoute = ApiDocsR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconMenuNews @@ -2698,6 +2712,19 @@ pageActions TopWorkflowInstanceListR = return , navChildren = [] } ] +pageActions ApiDocsR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSwagger + , navRoute = SwaggerR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] pageActions (TopWorkflowWorkflowListR lState) = let lState' | lState == WorkflowWorkflowListActive = WorkflowWorkflowListArchive | otherwise = WorkflowWorkflowListActive diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 9e7bc4c76..0489bdf03 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -11,6 +11,10 @@ import Foundation.Type import Foundation.Routes.Definitions + +import ServantApi.ExternalApis.Type + + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers @@ -47,6 +51,33 @@ deriving instance Generic SchoolWorkflowWorkflowR deriving instance Generic AMatchingR deriving instance Generic (Route UniWorX) + +instance Hashable CourseR +instance Hashable SheetR +instance Hashable SubmissionR +instance Hashable MaterialR +instance Hashable TutorialR +instance Hashable ExamR +instance Hashable EExamR +instance Hashable CourseApplicationR +instance Hashable AllocationR +instance Hashable SchoolR +instance Hashable ExamOfficeR +instance Hashable CourseNewsR +instance Hashable CourseEventR +instance Hashable AdminWorkflowDefinitionR +instance Hashable AdminWorkflowInstanceR +instance Hashable GlobalWorkflowInstanceR +instance Hashable GlobalWorkflowWorkflowR +instance Hashable SchoolWorkflowInstanceR +instance Hashable SchoolWorkflowWorkflowR +instance Hashable AMatchingR +instance Hashable (Route UniWorX) +instance Hashable (Route EmbeddedStatic) where + hashWithSalt s = hashWithSalt s . renderRoute +instance Hashable (Route Auth) where + hashWithSalt s = hashWithSalt s . renderRoute + instance Ord (Route Auth) where compare = compare `on` renderRoute instance Ord (Route EmbeddedStatic) where @@ -77,6 +108,7 @@ deriving instance Ord (Route UniWorX) data RouteChildren type instance Children RouteChildren a = ChildrenRouteChildren a type family ChildrenRouteChildren a where + ChildrenRouteChildren (Route (ServantApi _)) = '[] ChildrenRouteChildren (Route EmbeddedStatic) = '[] ChildrenRouteChildren (Route Auth) = '[] ChildrenRouteChildren UUID = '[] diff --git a/src/Foundation/Servant.hs b/src/Foundation/Servant.hs new file mode 100644 index 000000000..380703d79 --- /dev/null +++ b/src/Foundation/Servant.hs @@ -0,0 +1,195 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances, InstanceSigs #-} + +module Foundation.Servant + ( ServantApiDispatchUniWorX(..) + , UniWorXContext + , ServantHandler, ServantDB + ) where + +import Import.Servant.NoFoundation +import Foundation.DB (runSqlPoolRetry') +import Foundation.Authorization (maybeBearerToken, IsDryRun(..), isDryRun) +import Foundation.Instances () + +import qualified Data.HashMap.Strict.InsOrd as HashMap + +import Network.Wai (Middleware, modifyResponse, mapResponseHeaders) +import qualified Network.Wai as W + +import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFail, delayedFailFatal) + +import qualified Yesod.Servant as Servant + +import qualified Data.Text as Text + +import Control.Monad.Catch.Pure + +import Servant.Server.Internal.Delayed +import Servant.Server.Internal.Router + +import Database.Persist.Sql (transactionUndo) + +import qualified Data.CaseInsensitive as CI + + +instance ( HasServer sub context + , ToJSON restr, FromJSON restr + , SBoolI (FoldRequired mods) + , HasContextEntry context (Maybe (BearerToken UniWorX)) + , HasContextEntry context (Maybe (Route UniWorX)) + ) + => HasServer (CaptureBearerRestriction' mods restr :> sub) context + where + type ServerT (CaptureBearerRestriction' mods restr :> sub) m + = RequiredArgument mods restr -> ServerT sub m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s + + route _ context subserver + = route (Proxy @sub) context (subserver `addAuthCheck` bearerCheck) + where + bearerCheck :: DelayedIO (RequiredArgument mods restr) + bearerCheck = do + let bearer :: Maybe (BearerToken UniWorX) + bearer = getContextEntry context + cRoute :: Maybe (Route UniWorX) + cRoute = getContextEntry context + + noRouteStored, noTokenProvided, noRestrictionProvided :: ServerError + noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." } + noRestrictionProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor the provided bearer token must contain a restriction entry for this route." } + noRouteStored = err500 { errBody = "servantYesodMiddleware did not store current route in WAI vault." } + + exceptT delayedFailFatal return $ do + cRoute' <- maybeExceptT' noRouteStored cRoute + + let mbRet :: Maybe (Maybe restr) + mbRet = bearer <&> preview (_bearerRestrictionIx cRoute') + case sbool @(FoldRequired mods) of + SFalse -> return $ join mbRet + STrue -> maybe (throwE noTokenProvided) (maybe (throwE noRestrictionProvided) return) mbRet + + +instance ( HasServer sub context + , SBoolI (FoldRequired mods) + , HasContextEntry context (Maybe (BearerToken UniWorX)) + ) + => HasServer (CaptureBearerToken' mods :> sub) context + where + type ServerT (CaptureBearerToken' mods :> sub) m + = RequiredArgument mods (BearerToken UniWorX) -> ServerT sub m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s + + route _ context subserver + = route (Proxy @sub) context (subserver `addAuthCheck` bearerCheck) + where + bearerCheck :: DelayedIO (RequiredArgument mods (BearerToken UniWorX)) + bearerCheck = do + let bearer :: Maybe (BearerToken UniWorX) + bearer = getContextEntry context + + noTokenProvided :: ServerError + noTokenProvided = err400 { errBody = "The behaviour of this route depends on restrictions stored in the bearer token used for authorization. Therefor providing a bearer token is required." } + + exceptT delayedFailFatal return $ do + case sbool @(FoldRequired mods) of + SFalse -> return bearer + STrue -> maybe (throwE noTokenProvided) return bearer + + +instance ( HasServer sub context + , HasCryptoID ciphertext plaintext (ReaderT CryptoIDKey Catch) + , SBoolI (FoldLenient mods) + , FromHttpApiData ciphertext + , HasContextEntry context UniWorX + ) => HasServer (CaptureCryptoID' mods ciphertext sym plaintext :> sub) context where + type ServerT (CaptureCryptoID' mods ciphertext sym plaintext :> sub) m + = If (FoldLenient mods) (Either String plaintext) plaintext -> ServerT sub m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @sub) pc nt . s + + route _ context subserver = CaptureRouter . + route (Proxy @sub) context . addCapture subserver $ \txt -> case ( sbool :: SBool (FoldLenient mods) + , decrypt' <$> parseUrlPiece txt + ) of + (SFalse, Left e ) -> delayedFail err400{ errBody = fromStrict $ encodeUtf8 e } + (SFalse, Right (Left _ )) -> delayedFail err400{ errBody = "Could not decrypt CryptoID" } + (SFalse, Right (Right pID)) -> return pID + (STrue, join -> piece) -> return $ left unpack piece + where + decrypt' :: CryptoID ciphertext plaintext -> Either Text plaintext + decrypt' inp = left tshow . runCatch . runReaderT (decrypt inp) . appCryptoIDKey $ getContextEntry context + + +type UniWorXContext = Maybe (Route UniWorX) ': Maybe (BearerToken UniWorX) ': IsDryRun ': UniWorX ': '[] +type ServantHandler = ServantHandlerFor UniWorX +type ServantDB = ServantDBFor UniWorX + +deriving via (ServantLogYesod UniWorX) instance ServantLog UniWorX + +instance HasServantHandlerContext UniWorX where + data ServantHandlerContextFor UniWorX = ServantHandlerContextForUniWorX + { usctxSite :: UniWorX + , usctxRequest :: W.Request + , usctxIsDryRun :: IsDryRun + } + getSCtxSite = usctxSite + getSCtxRequest = usctxRequest + +class (HasServer (ServantApiUnproxy' proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy' proxy)) => ServantApiDispatchUniWorX proxy where + servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy' proxy) ServantHandler + +instance ServantApiDispatchUniWorX proxy => ServantApiDispatch UniWorXContext ServantHandler UniWorX proxy where + servantContext _ app _ = do + isDryRun' <- MkIsDryRun <$> isDryRun + restr <- maybeBearerToken + cRoute <- getCurrentRoute + return $ cRoute :. restr :. isDryRun' :. app :. EmptyContext + servantHoist _ usctxSite usctxRequest ctx = ($ ServantHandlerContextForUniWorX{ usctxIsDryRun = getContextEntry ctx, .. }) . unServantHandlerFor + servantMiddleware _ _ ctx = appEndo . foldMap Endo $ + guardOn (unIsDryRun $ getContextEntry ctx) (modifyResponse $ mapResponseHeaders setDryRunHeader) + ++ [ modifyResponse (mapResponseHeaders setDefaultHeaders) + , fixTrailingSlash + ] + servantYesodMiddleware _ _ = return id + servantServer proxy _ = servantServer' proxy + +setDefaultHeaders, setDryRunHeader :: ResponseHeaders -> ResponseHeaders +setDefaultHeaders existing = HashMap.toList $ HashMap.fromList existing <> defaultHeaders + where defaultHeaders = HashMap.fromList + [ ("X-Frame-Options", "sameorigin") + , ("X-Content-Type-Options", "nosniff") + , ("Vary", "Accept") + , ("X-XSS-Protection", "1; mode=block") + ] +setDryRunHeader existing = HashMap.toList $ HashMap.fromList existing <> HashMap.singleton (CI.mk . encodeUtf8 $ toPathPiece HeaderDryRun) (encodeUtf8 $ toPathPiece True) + +fixTrailingSlash :: Middleware +-- ^ `servant-server` contains a special case in their implementation +-- of `runRouter`, that discards trailing slashes. +-- +-- Because all slashes matter, this duplicates trailing slashes. +fixTrailingSlash = (. fixTrailingSlash') + where fixTrailingSlash' req + | Just pathInfo' <- fromNullable $ W.pathInfo req + , Text.null $ last pathInfo' + = req { W.pathInfo = W.pathInfo req ++ [Text.empty] } + | otherwise + = req + + +instance ServantPersist UniWorX where + runDB :: HasCallStack => ServantDBFor UniWorX a -> ServantHandlerFor UniWorX a + runDB = runDB' callStack + +runDB' :: CallStack -> ServantDBFor UniWorX a -> ServantHandlerFor UniWorX a +runDB' lbl action = do + $logDebugS "ServantPersist" "runDB" + MkIsDryRun dryRun <- getsServantContext usctxIsDryRun + let action' + | dryRun = action <* transactionUndo + | otherwise = action + + flip (runSqlPoolRetry' action') lbl . appConnPool =<< getSite diff --git a/src/Foundation/Servant/Types.hs b/src/Foundation/Servant/Types.hs new file mode 100644 index 000000000..f10462d14 --- /dev/null +++ b/src/Foundation/Servant/Types.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Foundation.Servant.Types + ( CaptureBearerRestriction, CaptureBearerRestriction' + , CaptureBearerToken, CaptureBearerToken' + , CaptureCryptoID', CaptureCryptoID, CaptureCryptoUUID, CaptureCryptoFileName + , ApiVersion, apiVersionToSemVer, matchesApiVersion + , BearerAuth, SessionAuth + ) where + +import ClassyPrelude hiding (fromList) +import Data.Proxy + +import Servant.API +import Servant.API.Modifiers (FoldRequired) +import Servant.API.Description +import Servant.Swagger +import Servant.Docs +import Servant.Server +import Servant.Server.Internal.Router +import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.Delayed +import Servant.Server.Internal.ErrorFormatter +-- import Servant.Server.Internal.DelayedIO + +import Servant.Client.Core.RunClient (RunClient) +import Servant.Client.Core.HasClient +import qualified Servant.Client.Core.Request as Servant (Request) +import qualified Servant.Client.Core.Request as Request + +import Jose.Jwt (Jwt(..)) + +import Network.Wai (mapResponseHeaders, requestHeaders) + +import Control.Lens hiding (Context) + +import Data.UUID (UUID) +import Data.CaseInsensitive (CI) +import Data.CryptoID.Class.ImplicitNamespace +import Data.CryptoID.Instances () + +import GHC.TypeLits +import GHC.Exts (IsList(..)) + +import Data.Swagger hiding (version) + +import Data.Kind (Type) + +import qualified Data.SemVer as SemVer +import qualified Data.SemVer.Constraint as SemVer (Constraint) +import qualified Data.SemVer.Constraint as SemVer.Constraint + +import Data.SemVer.Instances () + + +type CaptureBearerRestriction = CaptureBearerRestriction' '[Required] +data CaptureBearerRestriction' (mods :: [Type]) (restr :: Type) + +type CaptureBearerToken = CaptureBearerToken' '[Required] +data CaptureBearerToken' (mods :: [Type]) + +data CaptureCryptoID' (mods :: [Type]) (ciphertext :: Type) (sym :: Symbol) (plaintext :: Type) +type CaptureCryptoID = CaptureCryptoID' '[] +type CaptureCryptoUUID = CaptureCryptoID UUID +type CaptureCryptoFileName = CaptureCryptoID (CI FilePath) + +data ApiVersion (major :: Nat) (minor :: Nat) (patch :: Nat) + +apiVersionToSemVer :: forall major minor patch p. + ( KnownNat major, KnownNat minor, KnownNat patch ) + => p (ApiVersion major minor patch) + -> SemVer.Version +apiVersionToSemVer _ = SemVer.version + (fromIntegral . natVal $ Proxy @major) + (fromIntegral . natVal $ Proxy @minor) + (fromIntegral . natVal $ Proxy @patch) + [] + [] + +matchesApiVersion :: forall major minor patch p. + ( KnownNat major, KnownNat minor, KnownNat patch ) + => p (ApiVersion major minor patch) + -> SemVer.Constraint + -> Bool +matchesApiVersion _ = SemVer.Constraint.satisfies . apiVersionToSemVer $ Proxy @(ApiVersion major minor patch) + + +instance HasLink sub => HasLink (CaptureBearerRestriction' mods restr :> sub) where + type MkLink (CaptureBearerRestriction' mods restr :> sub) r = MkLink sub r + toLink toA _ = toLink toA $ Proxy @sub + +instance HasLink sub => HasLink (CaptureBearerToken' mods :> sub) where + type MkLink (CaptureBearerToken' mods :> sub) r = MkLink sub r + toLink toA _ = toLink toA $ Proxy @sub + +instance (HasLink sub, ToHttpApiData ciphertext) => HasLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where + type MkLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) r = MkLink (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) r + toLink toA _ = toLink toA $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub) + +instance HasLink sub => HasLink (ApiVersion major minor patch :> sub) where + type MkLink (ApiVersion major minor patch :> sub) r = MkLink sub r + toLink toA _ = toLink toA $ Proxy @sub + +instance HasSwagger sub => HasSwagger (CaptureBearerRestriction' mods restr :> sub) where + toSwagger _ = toSwagger $ Proxy @sub + +instance HasSwagger sub => HasSwagger (CaptureBearerToken' mods :> sub) where + toSwagger _ = toSwagger $ Proxy @sub + +instance (HasSwagger sub, ToParamSchema ciphertext, KnownSymbol sym, KnownSymbol (FoldDescription mods)) => HasSwagger (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where + toSwagger _ = toSwagger $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub) + +instance HasSwagger sub => HasSwagger (ApiVersion major minor patch :> sub) where + toSwagger _ = toSwagger $ Proxy @sub + +instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) where + docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action') + where action' = action & notes <>~ [DocNote "Bearer restrictions" ["The behaviour of this route dependes on the restrictions stored for it in the bearer token used for authorization"]] + +instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where + docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action') + where action' = action & notes <>~ [DocNote "Bearer token" ["The behaviour of this route dependes on the exact bearer token used for authorization"]] + +instance (ToCapture (Capture sym ciphertext), KnownSymbol sym, HasDocs sub) => HasDocs (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where + docsFor _ = docsFor $ Proxy @(Capture' mods sym ciphertext :> sub) + +instance (RunClient m, HasClient m (Capture' mods sym (CryptoID ciphertext plaintext) :> sub)) => HasClient m (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where + type Client m (CaptureCryptoID' mods ciphertext sym plaintext :> sub) = Client m (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) + clientWithRoute pm _ = clientWithRoute pm $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub) + hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub) + + +type family ApiVersionSub major minor patch sup sub where + ApiVersionSub major minor patch (ApiVersion major' minor' patch') sub = ApiVersion major' minor' patch' :> sub + ApiVersionSub major minor patch sup sub = sup :> (ApiVersion major minor patch :> sub) + +instance HasServer (ApiVersionSub major minor patch sup sub) context => HasServer (ApiVersion major minor patch :> ((sup :: Type) :> sub)) context where + type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (ApiVersionSub major minor patch sup sub) m + hoistServerWithContext _ = hoistServerWithContext $ Proxy @(ApiVersionSub major minor patch sup sub) + route _ = route $ Proxy @(ApiVersionSub major minor patch sup sub) + +instance HasServer (sup :> (ApiVersion major minor patch :> sub)) context => HasServer (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) context where + type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (sup :> (ApiVersion major minor patch :> sub)) m + hoistServerWithContext _ = hoistServerWithContext $ Proxy @(sup :> (ApiVersion major minor patch :> sub)) + route _ = route $ Proxy @(sup :> (ApiVersion major minor patch :> sub)) + +instance ( HasServer (ApiVersion major minor patch :> a) context + , HasServer (ApiVersion major minor patch :> b) context + , SBoolI (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b)))) + ) => HasServer (ApiVersion major minor patch :> (a :<|> b)) context where + type ServerT (ApiVersion major minor patch :> (a :<|> b)) m = ServerT (ApiVersion major minor patch :> a) m :<|> ServerT (ApiVersion major minor patch :> b) m + hoistServerWithContext _ = hoistServerWithContext $ Proxy @((ApiVersion major minor patch :> a) :<|> (ApiVersion major minor patch :> b)) + route Proxy context server = choice' + (route (Proxy @(ApiVersion major minor patch :> a)) context $ (\(a :<|> _) -> a) <$> server) + (route (Proxy @(ApiVersion major minor patch :> b)) context $ (\(_ :<|> b) -> b) <$> server) + where + choice' :: forall env' a'. Router' env' a' -> Router' env' a' -> Router' env' a' + choice' = case (sbool :: SBool (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))) of + STrue -> flip choice + SFalse -> choice + +instance (RunClient m, HasClient m (ApiVersionSub major minor patch sup sub)) => HasClient m (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where + type Client m (ApiVersion major minor patch :> (sup :> sub)) = Client m (ApiVersionSub major minor patch sup sub) + clientWithRoute pm _ = clientWithRoute pm $ Proxy @(ApiVersionSub major minor patch sup sub) + hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(ApiVersionSub major minor patch sup sub) + +instance (RunClient m, HasClient m (sup :> (ApiVersion major minor patch :> sub))) => HasClient m (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where + type Client m (ApiVersion major minor patch :> (sup :> sub)) = Client m (sup :> (ApiVersion major minor patch :> sub)) + clientWithRoute pm _ = clientWithRoute pm $ Proxy @(sup :> (ApiVersion major minor patch :> sub)) + hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(sup :> (ApiVersion major minor patch :> sub)) + +instance ( HasClient m (ApiVersion major minor patch :> a) + , HasClient m (ApiVersion major minor patch :> b) + ) => HasClient m (ApiVersion major minor patch :> (a :<|> b)) where + type Client m (ApiVersion major minor patch :> (a :<|> b)) = Client m (ApiVersion major minor patch :> a) :<|> Client m (ApiVersion major minor patch :> b) + clientWithRoute pm _ req = clientWithRoute pm (Proxy @(ApiVersion major minor patch :> a)) req + :<|> clientWithRoute pm (Proxy @(ApiVersion major minor patch :> b)) req + hoistClientMonad pm _ f (ca :<|> cb) = hoistClientMonad pm (Proxy @(ApiVersion major minor patch :> a)) f ca + :<|> hoistClientMonad pm (Proxy @(ApiVersion major minor patch :> b)) f cb + + +versionRequestHeaderName :: CI ByteString +versionRequestHeaderName = "Accept-API-Version" + +routeWithApiVersion :: forall api context env major minor patch. + ( HasServer api context + , KnownNat major, KnownNat minor, KnownNat patch + , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters + ) + => Proxy (ApiVersion major minor patch) + -> Proxy api -> Context context -> Delayed env (Server api) -> Router env +routeWithApiVersion _ _ context subserver = RawRouter $ \env req ((. addVersion) -> cont) -> case maybe (pure SemVer.Constraint.CAny) parseHeader . lookup versionRequestHeaderName $ requestHeaders req of + Left parseErr -> cont $ FailFatal err400 { errBody = encodeUtf8 . fromStrict $ "Could not parse version constraint: " <> parseErr } + Right vHdr -> if + | version `SemVer.Constraint.satisfies` vHdr -> runRouterEnv notFound (route (Proxy @api) context subserver) env req cont + | otherwise -> cont $ Fail err400 { errBody = encodeUtf8 "Requested version could not be satisfied" } + where addVersion (Fail sError) = Fail sError { errHeaders = addVersionHeader $ errHeaders sError} + addVersion (FailFatal sError) = FailFatal sError { errHeaders = addVersionHeader $ errHeaders sError } + addVersion (Route resp) = Route $ mapResponseHeaders addVersionHeader resp + + addVersionHeader hdrs + | has (folded . _1 . only versionHeaderName) hdrs = hdrs + | otherwise = hdrs <> pure (versionHeaderName, versionHeader) + + version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch) + + versionHeaderName = "API-Version" + versionHeader = encodeUtf8 $ SemVer.toText version + + notFound = notFoundErrorFormatter . getContextEntry $ mkContextWithErrorFormatter context + +instance ( HasServer (Verb method statusCode contentTypes a) context + , KnownNat major, KnownNat minor, KnownNat patch + , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters + ) => HasServer (ApiVersion major minor patch :> Verb method statusCode contentTypes a) context where + type ServerT (ApiVersion major minor patch :> Verb method statusCode contentTypes a) m = ServerT (Verb method statusCode contentTypes a) m + + hoistServerWithContext _ = hoistServerWithContext $ Proxy @(Verb method statusCode contentTypes a) + + route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(Verb method statusCode contentTypes a)) + +instance ( HasServer (NoContentVerb method) context + , KnownNat major, KnownNat minor, KnownNat patch + , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters + ) => HasServer (ApiVersion major minor patch :> NoContentVerb method) context where + type ServerT (ApiVersion major minor patch :> NoContentVerb method) m = ServerT (NoContentVerb method) m + + hoistServerWithContext _ = hoistServerWithContext $ Proxy @(NoContentVerb method) + + route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(NoContentVerb method)) + + +semVerCompatibleTo :: SemVer.Version -> SemVer.Constraint +semVerCompatibleTo v = SemVer.Constraint.CAnd (SemVer.Constraint.CGtEq v) (SemVer.Constraint.CLt $ SemVer.incrementMajor v) + +instance ( HasClient m (Verb method statusCode contentTypes a) + , KnownNat major, KnownNat minor, KnownNat patch + ) => HasClient m (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where + type Client m (ApiVersion major minor patch :> Verb method statusCode contentTypes a) = Client m (Verb method statusCode contentTypes a) + clientWithRoute pm _ = clientWithRoute pm (Proxy @(Verb method statusCode contentTypes a)) . Request.addHeader versionRequestHeaderName (semVerCompatibleTo version) + where version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch) + hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(Verb method statusCode contentTypes a) + +instance ( HasClient m (NoContentVerb method) + , KnownNat major, KnownNat minor, KnownNat patch + ) => HasClient m (ApiVersion major minor patch :> NoContentVerb method) where + type Client m (ApiVersion major minor patch :> NoContentVerb method) = Client m (NoContentVerb method) + clientWithRoute pm _ = clientWithRoute pm (Proxy @(NoContentVerb method)) . Request.addHeader versionRequestHeaderName (semVerCompatibleTo version) + where version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch) + hoistClientMonad pm _ = hoistClientMonad pm $ Proxy @(NoContentVerb method) + + +instance ( HasDocs (ApiVersionSub major minor patch sup sub) + ) => HasDocs (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where + docsFor _ = docsFor $ Proxy @(ApiVersionSub major minor patch sup sub) + +instance ( HasDocs (sup :> (ApiVersion major minor patch :> sub)) + ) => HasDocs (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where + docsFor _ = docsFor $ Proxy @(sup :> (ApiVersion major minor patch :> sub)) + +instance ( HasDocs (ApiVersion major minor patch :> a) + , HasDocs (ApiVersion major minor patch :> b) + ) => HasDocs (ApiVersion major minor patch :> (a :<|> b)) where + docsFor _ = docsFor $ Proxy @(ApiVersion major minor patch :> a :<|> ApiVersion major minor patch :> b) + + +apiVersionDocNote :: forall major minor patch. + ( KnownNat major, KnownNat minor, KnownNat patch ) + => Proxy (ApiVersion major minor patch) + -> DocNote +apiVersionDocNote p = DocNote "Versioning" ["This route is provided in version " <> SemVer.toString (apiVersionToSemVer p)] + +instance ( HasDocs (Verb method statusCode contentTypes a) + , KnownNat major, KnownNat minor, KnownNat patch + ) => HasDocs (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where + docsFor _ (endpoint, action) = docsFor (Proxy @(Verb method statusCode contentTypes a)) (endpoint, action') + where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)] + +instance ( HasDocs (NoContentVerb method) + , KnownNat major, KnownNat minor, KnownNat patch + ) => HasDocs (ApiVersion major minor patch :> NoContentVerb method) where + docsFor _ (endpoint, action) = docsFor (Proxy @(NoContentVerb method)) (endpoint, action') + where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)] + + +type family FinalApiVersion api where + FinalApiVersion (ApiVersion major minor patch :> sub) = AlternativeMaybe (FinalApiVersion sub) ('Just (ApiVersion major minor patch)) + FinalApiVersion (sup :> sub) = FinalApiVersion sub + FinalApiVersion (a :<|> b) = MaxMaybe (CmpVersion (FinalApiVersion a) (FinalApiVersion b)) (FinalApiVersion a) (FinalApiVersion b) + FinalApiVersion (Verb method statusCode contentTypes a) = 'Nothing + FinalApiVersion (NoContentVerb method) = 'Nothing + +type family MaxMaybe ord a b where + MaxMaybe _ a 'Nothing = a + MaxMaybe _ 'Nothing b = b + MaxMaybe 'LT _ b = b + MaxMaybe _ a _ = a + +type family MappendOrdering a b where + MappendOrdering 'EQ b = b + MappendOrdering a _ = a + +type family AlternativeMaybe a b where + AlternativeMaybe ('Just a) _ = 'Just a + AlternativeMaybe _ ('Just b) = 'Just b + AlternativeMaybe _ _ = 'Nothing + +type family CmpVersion x y where + CmpVersion 'Nothing 'Nothing = 'EQ + CmpVersion 'Nothing _ = 'GT + CmpVersion _ 'Nothing = 'LT + CmpVersion ('Just (ApiVersion major minor patch)) ('Just (ApiVersion major' minor' patch')) = MappendOrdering (CmpNat major major') (MappendOrdering (CmpNat minor minor') (CmpNat patch patch')) + +type family IsLT x where + IsLT 'LT = 'True + IsLT _ = 'False + + +type instance IsElem' sa (CaptureCryptoID' mods ciphertext sym plaintext :> sb) = IsElem sa (Capture' mods sym (CryptoID ciphertext plaintext) :> sb) + +type instance IsElem' sa (ApiVersion major minor patch :> sb) = IsElem sa sb + + +type family StripBearer api where + StripBearer (CaptureBearerRestriction' mods restr :> sub) = sub + StripBearer (CaptureBearerToken' mods :> sub) = sub + StripBearer (BearerAuth :> sub) = sub + StripBearer (sup :> sub) = sup :> StripBearer sub + StripBearer (a :<|> b) = StripBearer a :<|> StripBearer b + StripBearer (Verb method statusCode contentTypes a) = Verb method statusCode contentTypes a + StripBearer (NoContentVerb method) = NoContentVerb method + +type family BearerRequired api where + BearerRequired (CaptureBearerRestriction' mods restr :> sub) = OrBool (FoldRequired mods) (BearerRequired sub) + BearerRequired (CaptureBearerToken' mods :> sub) = OrBool (FoldRequired mods) (BearerRequired sub) + BearerRequired (BearerAuth :> sub) = 'True + BearerRequired (sup :> sub) = BearerRequired sub + BearerRequired (a :<|> b) = OrBool (BearerRequired a) (BearerRequired b) + BearerRequired (Verb method statusCode contentTypes a) = 'False + BearerRequired (NoContentVerb method) = 'False + +type family OrBool a b where + OrBool 'False 'False = 'False + OrBool a b = 'True + +maybeWithJwt :: forall (a :: Bool). SBoolI a => Proxy a -> If a Jwt (Maybe Jwt) -> Servant.Request -> Servant.Request +maybeWithJwt _ mparam = case (sbool :: SBool a, mparam) of + (STrue, jwt) -> add jwt + (SFalse, mJwt) -> maybe id add mJwt + where add (Jwt jwt) = Request.addHeader "Authorization" . decodeUtf8 $ "Bearer " <> jwt + +instance ( HasClient m (StripBearer sub) + , RunClient m + , SBoolI (BearerRequired (CaptureBearerRestriction' mods restr :> sub)) + ) => HasClient m (CaptureBearerRestriction' mods restr :> sub) where + type Client m (CaptureBearerRestriction' mods restr :> sub) = If (BearerRequired (CaptureBearerRestriction' mods restr :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub) + clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (CaptureBearerRestriction' mods restr :> sub))) mparam req + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl + +instance ( HasClient m (StripBearer sub) + , RunClient m + , SBoolI (BearerRequired (CaptureBearerToken' mods :> sub)) + ) => HasClient m (CaptureBearerToken' mods :> sub) where + type Client m (CaptureBearerToken' mods :> sub) = If (BearerRequired (CaptureBearerToken' mods :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub) + clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (CaptureBearerToken' mods :> sub))) mparam req + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl + +instance ( HasClient m (StripBearer sub) + , RunClient m + , SBoolI (BearerRequired (BearerAuth :> sub)) + ) => HasClient m (BearerAuth :> sub) where + type Client m (BearerAuth :> sub) = If (BearerRequired (BearerAuth :> sub)) Jwt (Maybe Jwt) -> Client m (StripBearer sub) + clientWithRoute pm _ req mparam = clientWithRoute pm (Proxy @(StripBearer sub)) $ maybeWithJwt (Proxy @(BearerRequired (BearerAuth :> sub))) mparam req + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @(StripBearer sub)) f . cl + + +data BearerAuth +data SessionAuth + +instance HasSwagger sub => HasSwagger (BearerAuth :> sub) where + toSwagger _ = toSwagger (Proxy @sub) + & securityDefinitions <>~ SecurityDefinitions (fromList [(defnKey, defn)]) + & allOperations . security <>~ [SecurityRequirement $ fromList [(defnKey, [])]] + where defnKey :: Text + defnKey = "bearer" + defn = SecurityScheme + { _securitySchemeType + = SecuritySchemeApiKey ApiKeyParams + { _apiKeyName = "Authorization" + , _apiKeyIn = ApiKeyHeader + } + , _securitySchemeDescription = Just + "JSON Web Token-based API key" + } + +instance HasSwagger sub => HasSwagger (SessionAuth :> sub) where + toSwagger _ = toSwagger (Proxy @sub) + & allOperations . security <>~ [SecurityRequirement mempty] + -- We do not expect API clients to be able/willing to conform with + -- our CSRF mitigation, so we mark routes that require it as + -- having unfullfillable security requirements + +instance HasLink sub => HasLink (BearerAuth :> sub) where + type MkLink (BearerAuth :> sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy @sub) + +instance HasLink sub => HasLink (SessionAuth :> sub) where + type MkLink (SessionAuth :> sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy @sub) + +instance HasDocs sub => HasDocs (BearerAuth :> sub) where + docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action') + where action' = action & authInfo %~ (|> authInfo') + authInfo' = DocAuthentication + "" + "A JSON Web Token-based API key" + +instance HasDocs sub => HasDocs (SessionAuth :> sub) where + docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action') + where action' = action & authInfo %~ (|> authInfo') + authInfo' = DocAuthentication + "When a web session is used for authorization, CSRF-mitigation measures must be observed." + "An active web session identifying the user as one with sufficient authorization" diff --git a/src/Handler/ApiDocs.hs b/src/Handler/ApiDocs.hs new file mode 100644 index 000000000..6775333dc --- /dev/null +++ b/src/Handler/ApiDocs.hs @@ -0,0 +1,35 @@ +module Handler.ApiDocs + ( getApiDocsR + ) where + +import Import +import ServantApi + +import qualified Servant.Docs as Servant + +import Servant.Docs.Internal.Pretty + +import Handler.Utils.Pandoc + + +getApiDocsR :: Handler TypedContent +getApiDocsR = selectRep $ do + case htmlDocs of + Right html -> provideRep . siteLayoutMsg MsgBreadcrumbApiDocs $ do + setTitleI MsgBreadcrumbApiDocs + + [whamlet| + $newline never +
+ ^{html} + |] + Left _err -> return () + provideRepType "text/markdown" $ return mdDocs + where + mdDocs = pack . Servant.markdown $ Servant.docsWith Servant.defaultDocOptions docIntros docExtra (Proxy @(Pretty UniWorXApi)) + htmlDocs = parseMarkdownWith markdownReaderOptions htmlWriterOptions mdDocs + + docIntros = mempty + docExtra = mconcat + [ + ] diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 927f98bac..25058461c 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -330,9 +330,8 @@ examPartsForm prev = wFormToAForm $ do miIdent' :: Text miIdent' = "exam-parts" -examFormTemplate :: ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadThrow m +examFormTemplate :: ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey ) => Entity Exam -> SqlPersistT m ExamForm examFormTemplate (Entity eId Exam{..}) = do @@ -342,8 +341,8 @@ examFormTemplate (Entity eId Exam{..}) = do invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId extraSchools <- selectList [ ExamOfficeSchoolExam ==. eId ] [] - examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part - occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ + examParts' <- lift . forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part + occurrences' <- lift . forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ mAuthorshipStatement <- maybe (pure Nothing) getEntity examAuthorshipStatement @@ -455,6 +454,8 @@ examTemplate cid = runMaybeT $ do validateExam :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadSite UniWorX (SqlPersistT m) + , MonadCryptoKey m ~ CryptoIDKey ) => CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) () validateExam cId oldExam = do @@ -495,7 +496,7 @@ validateExam cId oldExam = do , examOccurrence E.^. ExamOccurrenceName ) forM_ (join $ hoistMaybe oldOccurrencesWithRegistrations) $ \(E.Value eoId, E.Value eoName) -> - guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId + guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . lift . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId oldPartsWithResults <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examPart -> do diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs index d5af2a26d..fc4a2bdc5 100644 --- a/src/Handler/Metrics.hs +++ b/src/Handler/Metrics.hs @@ -2,7 +2,7 @@ module Handler.Metrics ( getMetricsR ) where -import Import hiding (Info) +import Import hiding (Info, samples, singleSample) import Prometheus import qualified Network.Wai.Middleware.Prometheus as Prometheus diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 6c1ec3048..b56651052 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -87,6 +87,7 @@ resolvePersonalisedSheetFiles :: forall m a. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadSite UniWorX (SqlPersistT m) , MonadCatch m, MonadRandom m ) => Lens' a FilePath @@ -133,6 +134,7 @@ resolvePersonalisedSheetFiles fpL isDir cid sid = do sinkPersonalisedSheetFiles :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadSite UniWorX (SqlPersistT m) , MonadCatch m, MonadRandom m ) => CourseId @@ -208,6 +210,7 @@ sinkPersonalisedSheetFiles cid sid keep sourcePersonalisedSheetFiles :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadSite UniWorX (SqlPersistT m) , MonadThrow m , MonadRandom m ) @@ -310,7 +313,7 @@ data PersonalisedSheetFilesKeyException newPersonalisedFilesKey :: forall m. ( MonadHandler m - , HandlerSite m ~ UniWorX + , MonadSite UniWorX (SqlPersistT m) , MonadThrow m, MonadRandom m ) => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, PersonalisedSheetFilesKeySet) @@ -318,7 +321,7 @@ newPersonalisedFilesKey (Right shId) = (Nothing, ) <$> do psfksCryptoID <- cryptoIDKey $ \cIDKey -> either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $ Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey - psfksSeed <- fmap Just . getsYesod . views _appPersonalisedSheetFilesSeedKey . flip derivePersonalisedSheetFilesSeedKey . toStrict $ Binary.encode (nameBase 'newPersonalisedFilesKey, shId) + psfksSeed <- fmap Just . getsSite . views _appPersonalisedSheetFilesSeedKey . flip derivePersonalisedSheetFilesSeedKey . toStrict $ Binary.encode (nameBase 'newPersonalisedFilesKey, shId) return PersonalisedSheetFilesKeySet{..} newPersonalisedFilesKey (Left cId) = do now <- liftIO getCurrentTime @@ -342,7 +345,7 @@ newPersonalisedFilesKey (Left cId) = do getPersonalisedFilesKey :: forall m. ( MonadHandler m - , HandlerSite m ~ UniWorX + , MonadSite UniWorX (SqlPersistT m) , MonadThrow m, MonadRandom m ) => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m PersonalisedSheetFilesKeySet diff --git a/src/Handler/Swagger.hs b/src/Handler/Swagger.hs new file mode 100644 index 000000000..665d7cb69 --- /dev/null +++ b/src/Handler/Swagger.hs @@ -0,0 +1,78 @@ +module Handler.Swagger + ( getSwaggerR, getSwaggerJsonR + ) where + +import Import hiding (host, Response, Scheme(..)) +import ServantApi + +import Data.Swagger +import Data.Swagger.Declare (Declare) +import Servant.Swagger + +import Development.GitRev + +import Network.URI + +import Text.Read (readMaybe) + + +genSwagger :: Handler Swagger +genSwagger = do + app <- getYesod + let + docMR :: RenderMessage UniWorX msg => msg -> Text + docMR = renderMessage app . otoList $ selectLanguages appLanguages ["en"] + root <- getApprootText approot app <$> waiRequest + let applyApproot = do + URI{..} <- fmap rectify . parseURIReference $ unpack root + let mbScheme = do + str <- assertM (not . null) $ stripSuffix ":" uriScheme + case str of + "https" -> return Https + "http" -> return Http + _other -> mzero + applyAuthority = do + URIAuth{..} <- uriAuthority + let mbPort = readMaybe . fromMaybe "" $ stripPrefix ":" uriPort + return $ + host ?~ Host uriRegName mbPort + return $ \x -> x + & fromMaybe id applyAuthority + & schemes .~ fmap pure mbScheme + & basePath ?~ bool id (ensurePrefix "/") (is _Just mbScheme || is _Just uriAuthority) uriPath + errorResponses :: Map HttpStatusCode (Declare (Definitions Schema) Response) + errorResponses = mconcat + [ singletonMap 500 $ return mempty + , singletonMap 400 $ return mempty + , singletonMap 401 $ return mempty + , singletonMap 403 $ return mempty + , singletonMap 405 $ return mempty + ] + + tos <- toTextUrl $ LegalR :#: ("terms-of-use" :: Text) + c <- toTextUrl HelpR + + let supportContact = mempty + & name .~ addressName supportAddress + & email ?~ addressEmail supportAddress + & url ?~ URL c + where + supportAddress = appMailSupport $ appSettings' app + + return $ toSwagger uniworxApi + & info.title .~ docMR MsgLogo + & info.description ?~ docMR MsgInvitationUniWorXTip + & info.termsOfService ?~ tos + & info.contact ?~ supportContact + & info.version .~ $gitDescribe + & fromMaybe id applyApproot + & appEndo (ifoldMap ((Endo .) . setResponseWith const) errorResponses) + + +getSwaggerR :: Handler TypedContent +getSwaggerR = selectRep $ do + provideRep $ toPrettyJSON <$> genSwagger + provideRep $ toYAML <$> genSwagger + +getSwaggerJsonR :: Handler Void +getSwaggerJsonR = redirect SwaggerR diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index 28d723bb8..f351d328e 100644 --- a/src/Handler/Utils/Download.hs +++ b/src/Handler/Utils/Download.hs @@ -36,6 +36,7 @@ deriveJSON defaultOptions withFileDownloadTokenMaybe' :: forall url m. ( HasRoute UniWorX url , MonadHandler m, HandlerSite m ~ UniWorX + , MonadSite UniWorX m , MonadCrypto m , MonadCryptoKey m ~ CryptoIDKey , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId @@ -115,6 +116,7 @@ withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $ ensureApprootUserGeneratedMaybe' :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadSite UniWorX m , MonadCrypto m , MonadCryptoKey m ~ CryptoIDKey , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index b39d89428..42e9948ad 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -917,7 +917,7 @@ genericFileField mkOpts = Field{..} | otherwise = True - getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField FileReference -> m' (Maybe Text) + getIdent :: forall m'. (MonadHandler m', Hashable (Route (HandlerSite m'))) => FileField FileReference -> m' (Maybe Text) getIdent FileField{..} = do ident <- case fieldIdent of Just ident -> return $ Just ident diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 8de2c3a36..d23f0fe09 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -303,7 +303,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR shapeName :: MassInputFieldName (BoxCoord liveliness) shapeName = MassInputShape{..} shapeField :: Field handler (Map (BoxCoord liveliness) cellData) - shapeField = secretJsonField + shapeField = hoistField liftHandler secretJsonField sentShape <- runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 50e666ed0..bc0ad7619 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -987,7 +987,7 @@ addPIHiddenField DBTable{ dbtIdent } pi form fragment addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a) addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do - encrypted <- encodedSecretBox SecretBoxShort pKeys + encrypted <- liftHandler $ encodedSecretBox SecretBoxShort pKeys form $ fragment <> [shamlet| $newline never diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 99fe42538..97516fd6b 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -100,7 +100,7 @@ workflowR rScope cID = workflowsDisabledWarning title heading $ do archiveAfter <- MaybeT . getsYesod $ view _appWorkflowWorkflowArchiveAfter let WorkflowAction{wpTo,wpTime} = last nState WGN{wgnFinal} <- hoistMaybe $ Map.lookup wpTo wgNodes - return $ const (archiveAfter `addUTCTime` wpTime) <$> wgnFinal + return $ (archiveAfter `addUTCTime` wpTime) <$ wgnFinal update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState , WorkflowWorkflowArchived =. wwArchived diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 87ea8657b..16c566181 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -39,6 +39,13 @@ import Yesod.Auth as Import hiding (requireAuth, requireAuthId, requ import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import import Yesod.Core.Types.Instances as Import +import Yesod.Servant as Import + hiding ( MonadHandler(..), HasRoute(..), MonadRequest(..) + , runDB, defaultRunDB + ) +import Servant.Docs as Import + ( ToSample(..), samples, noSamples, singleSample + ) import Utils as Import import Utils.Frontend.I18n as Import @@ -182,6 +189,7 @@ import Database.Esqueleto.Instances as Import () import Numeric.Natural.Instances as Import () import Text.Blaze.Instances as Import () import Jose.Jwt.Instances as Import () +import Jose.Jwk.Instances as Import () import Web.PathPieces.Instances as Import () import Data.Universe.Instances.Reverse.MonoTraversable () import Data.Universe.Instances.Reverse.WithIndex () @@ -199,6 +207,12 @@ import Prometheus.Instances as Import () import Yesod.Form.Fields.Instances as Import () import Yesod.Form.Types.Instances as Import () import Data.MonoTraversable.Instances as Import () +import Servant.Client.Core.BaseUrl.Instances as Import () +import Control.Monad.Trans.Except.Instances as Import () +import Servant.Server.Instances as Import () +import Servant.Docs.Internal.Pretty.Instances as Import () +import Network.URI.Instances as Import () +import Data.HashSet.Instances as Import () import Web.Cookie.Instances as Import () import Network.HTTP.Types.Method.Instances as Import () import Crypto.Random.Instances as Import () @@ -210,9 +224,9 @@ import Database.Persist.Sql.Types.Instances as Import () import Control.Monad.Catch.Instances as Import () import Text.Shakespeare.Text.Instances as Import () import Ldap.Client.Instances as Import () -import Network.URI.Instances as Import () import Data.MultiSet.Instances as Import () import Control.Arrow.Instances as Import () +import Data.SemVer.Instances as Import () import Control.Monad.Trans.Random.Instances as Import () import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) diff --git a/src/Import/Servant.hs b/src/Import/Servant.hs new file mode 100644 index 000000000..05160ee18 --- /dev/null +++ b/src/Import/Servant.hs @@ -0,0 +1,9 @@ +module Import.Servant + ( module Import + ) where + +import Foundation as Import + hiding ( Handler + ) +import Foundation.Servant as Import +import Import.Servant.NoFoundation as Import diff --git a/src/Import/Servant/NoFoundation.hs b/src/Import/Servant/NoFoundation.hs new file mode 100644 index 000000000..c9b4e06c6 --- /dev/null +++ b/src/Import/Servant/NoFoundation.hs @@ -0,0 +1,46 @@ +module Import.Servant.NoFoundation + ( module Import + ) where + +import Import.NoFoundation as Import hiding + ( Context + , Authorized, Unauthorized + , ServerError + , Header + , Strict + , Headers + , addHeader + , runDB, defaultRunDB + , MonadHandler(..), HasRoute(..), liftHandler + , encrypt, decrypt + , Unique, Fragment(..), respond + , getRequest + ) + +import Yesod.Servant as Import +import Foundation.Servant.Types as Import + +import Foundation.Type as Import + +import Servant.API as Import +import Servant.API.Modifiers as Import +import Servant.Server as Import +import Servant.Docs as Import + ( ToCapture(..), DocCapture(..) + , ToParam(..), DocQueryParam(..), ParamKind + ) +import Servant.Docs.Internal.Pretty as Import (PrettyJSON) +import Data.Swagger as Import (SwaggerType(..), Referenced(..)) +import Data.Swagger.Schema as Import hiding (SchemaOptions(..)) +import Data.Swagger.Internal.Schema as Import (named) +import Data.Swagger.Lens as Import hiding + ( host, port, get, put, delete, allOf + , format, minLength, maxLength + ) + +import Servant.API.Generic as Import +import Servant.Server.Generic as Import + +import Data.CryptoID.Class.ImplicitNamespace as Import (encrypt, decrypt) + +import Control.Monad.Error.Class as Import (MonadError(..)) diff --git a/src/Jobs.hs b/src/Jobs.hs index 7fe2fcf9c..3a8a94e4a 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -71,6 +71,7 @@ import Jobs.Handler.SynchroniseLdap import Jobs.Handler.PruneInvitations import Jobs.Handler.ChangeUserDisplayEmail import Jobs.Handler.Files +import Jobs.Handler.ExternalApis import Jobs.Handler.PersonalisedSheetFiles import Jobs.Handler.PruneOldSentMails import Jobs.Handler.StudyFeatures diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 368daf8de..9de2ac144 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -586,6 +586,7 @@ determineCrontab = execWriterT $ do , cronNotAfter = maybe (Right CronNotScheduled) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) $ nBot =<< minimumOf (folded . _entityVal . _allocationStaffAllocationTo . to NTop . filtered (> NTop (Just registerTo))) allocs } + hasRelevanceUncached <- lift $ exists [StudyFeaturesRelevanceCached ==. Nothing] when hasRelevanceUncached . tell $ HashMap.singleton (JobCtlQueue JobStudyFeaturesCacheRelevance) @@ -595,3 +596,16 @@ determineCrontab = execWriterT $ do , cronRateLimit = nominalDay , cronNotAfter = Right CronNotScheduled } + + + let externalApiJobs (Entity jExternalApi ExternalApi{..}) = + tell $ HashMap.singleton + (JobCtlQueue JobExternalApiExpire{..}) + Cron + { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appExternalApisExpiry externalApiLastAlive + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appExternalApisExpiry + , cronNotAfter = Right CronNotScheduled + } + + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalApiJobs diff --git a/src/Jobs/Handler/ExternalApis.hs b/src/Jobs/Handler/ExternalApis.hs new file mode 100644 index 000000000..8d5e9fa71 --- /dev/null +++ b/src/Jobs/Handler/ExternalApis.hs @@ -0,0 +1,15 @@ +module Jobs.Handler.ExternalApis + ( dispatchJobExternalApiExpire + ) where + +import Import + + +dispatchJobExternalApiExpire :: ExternalApiId -> JobHandler UniWorX +dispatchJobExternalApiExpire apiId = JobHandlerAtomic $ do + now <- liftIO getCurrentTime + expiry <- getsYesod $ view _appExternalApisExpiry + void . runMaybeT $ do + ExternalApi{..} <- MaybeT $ get apiId + guard $ externalApiLastAlive <= addUTCTime (- expiry) now + lift $ delete apiId diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 9efc5df8c..067a1ccb1 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -94,6 +94,8 @@ data Job , jEpoch , jIteration :: Natural } + | JobExternalApiExpire { jExternalApi :: ExternalApiId + } | JobInjectFiles | JobPruneFallbackPersonalisedSheetFilesKeys | JobRechunkFiles diff --git a/src/Jose/Jwk/Instances.hs b/src/Jose/Jwk/Instances.hs new file mode 100644 index 000000000..e3782d506 --- /dev/null +++ b/src/Jose/Jwk/Instances.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Jose.Jwk.Instances + () where + +import ClassyPrelude + +import Model.Types.TH.JSON + +import Jose.Jwk +import Jose.Jwt +import Jose.Jwa +import Crypto.PubKey.ECC.Types +import Crypto.PubKey.ECC.ECDSA + +import Data.Swagger.Schema (ToSchema(..)) +import Data.Swagger.Internal.Schema (named) + +import Servant.Docs (ToSample(..)) + +import Crypto.Random + + +deriving instance Generic EcCurve +deriving anyclass instance NFData EcCurve +deriving instance Generic CurveCommon +deriving anyclass instance NFData CurveCommon +deriving instance Generic CurvePrime +deriving anyclass instance NFData CurvePrime +deriving instance Generic Curve +deriving anyclass instance NFData Curve +deriving instance Generic PublicKey +deriving anyclass instance NFData PublicKey +deriving instance Generic JweAlg +deriving anyclass instance NFData JweAlg +deriving instance Generic JwsAlg +deriving anyclass instance NFData JwsAlg +deriving instance Generic Alg +deriving anyclass instance NFData Alg +deriving instance Generic KeyUse +deriving anyclass instance NFData KeyUse +deriving instance Generic KeyId +deriving anyclass instance NFData KeyId +deriving instance Generic KeyPair +deriving anyclass instance NFData KeyPair +deriving instance Generic Jwk +deriving anyclass instance NFData Jwk + + +derivePersistFieldJSON ''JwkSet + +deriving anyclass instance NFData JwkSet + +instance ToSchema Jwk where + declareNamedSchema _ = pure $ named "Jwk" mempty + +instance ToSchema JwkSet + + +sampleNotRandom :: MonadPseudoRandom ChaChaDRG a -> a +sampleNotRandom = fst . withDRG (drgNewSeed $ seedFromInteger 0) + +instance ToSample JwkSet where + toSamples _ = [ ("Symmetric key", JwkSet [symmKey]) + , ("Asymmetric keyset", JwkSet [rsaPub, rsaPriv]) + , ("Symmetric & asymmetric keysets", JwkSet [symmKey, rsaPub, rsaPriv]) + ] + where + symmKey = sampleNotRandom $ + generateSymmetricKey 8 (KeyId "sample") Enc Nothing + + (rsaPub, rsaPriv) = sampleNotRandom $ + generateRsaKeyPair 128 (KeyId "sample RSA") Enc Nothing diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs index 0c0c093ef..5b8818238 100644 --- a/src/Jose/Jwt/Instances.hs +++ b/src/Jose/Jwt/Instances.hs @@ -5,6 +5,7 @@ module Jose.Jwt.Instances ) where import ClassyPrelude.Yesod +import Model.Types.TH.PathPiece import Jose.Jwt @@ -13,6 +14,7 @@ deriving instance Ord Jwt deriving instance Read Jwt deriving instance Generic Jwt deriving instance Typeable Jwt +deriving anyclass instance NFData Jwt instance PathPiece Jwt where toPathPiece (Jwt bytes) = decodeUtf8 bytes @@ -20,6 +22,8 @@ instance PathPiece Jwt where instance Hashable Jwt +derivePersistFieldPathPiece ''Jwt + deriving instance Generic JwtError deriving instance Typeable JwtError diff --git a/src/Model.hs b/src/Model.hs index 9c572b67a..079c9d3e6 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -49,6 +49,9 @@ deriving newtype instance FromJSONKey UserId deriving newtype instance ToJSONKey ExamOccurrenceId deriving newtype instance FromJSONKey ExamOccurrenceId +deriving newtype instance ToSample UserId +deriving newtype instance ToSample ExternalApiId + deriving instance Show (Unique ExamPart) -- ToMarkup and ToMessage instances for displaying selected database primary keys diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 80e97dd07..afa049943 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1073,10 +1073,10 @@ customMigrations = mapF $ \case let mArchiveAfter = Just (5270400 :: NominalDiffTime) [executeQQ| ALTER TABLE "workflow_workflow" ADD "archived" timestamp with time zone; |] let getWorkflows = [queryQQ| SELECT "workflow_workflow"."id", "workflow_workflow"."state"->-1->'time', "workflow_workflow"."state"->-1->'to', "shared_workflow_graph"."graph" FROM "workflow_workflow" INNER JOIN "shared_workflow_graph" ON "workflow_workflow"."graph" = "shared_workflow_graph"."hash"; |] - migrateArchived [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTime), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTo), fromPersistValue -> Right (wGraph :: DBWorkflowGraph) ] = maybeT (return ()) $ do + migrateArchived [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTime), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTo), fromPersistValue -> Right (wGraph :: DBWorkflowGraph) ] = maybeT_ $ do archiveAfter <- hoistMaybe mArchiveAfter WGN{wgnFinal} <- hoistMaybe . Map.lookup wpTo $ wgNodes wGraph - let wwArchived = const (max now $ archiveAfter `addUTCTime` wpTime) <$> wgnFinal + let wwArchived = max now (archiveAfter `addUTCTime` wpTime) <$ wgnFinal lift [executeQQ| UPDATE "workflow_workflow" SET "archived" = #{wwArchived} WHERE "id" = #{wwId}; |] migrateArchived _ = return () in runConduit $ getWorkflows .| C.mapM_ migrateArchived diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index 09849ecb6..f5c4f4913 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/src/Model/Tokens/Bearer.hs @@ -10,7 +10,8 @@ module Model.Tokens.Bearer import ClassyPrelude.Yesod import Yesod.Core.Instances () - +import Yesod.Servant (MonadSite(..)) + import Model import Model.Tokens.Lens import Utils (assertM', foldMapM) @@ -117,17 +118,16 @@ bearerRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route si bearerRestrict route (toJSON -> resVal) = over _bearerRestrictions $ HashMap.insert route resVal - -bearerToJSON :: forall m. - ( MonadHandler m - , HasCryptoUUID (AuthId (HandlerSite m)) m - , RenderRoute (HandlerSite m) - ) => BearerToken (HandlerSite m) -> m Value +bearerToJSON :: forall site m. + ( MonadSite site m + , HasCryptoUUID (AuthId site) m + , RenderRoute site + ) => BearerToken site -> m Value -- ^ Encode a `BearerToken` analogously to `toJSON` -- -- Monadic context is needed because `AuthId`s are encrypted during encoding bearerToJSON BearerToken{..} = do - cID <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.encrypt)) bearerAuthority :: m (HashSet (Either Value (CryptoUUID (AuthId (HandlerSite m))))) + cID <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.encrypt)) bearerAuthority :: m (HashSet (Either Value (CryptoUUID (AuthId site)))) let stdPayload = Jose.JwtClaims { jwtIss = Just $ toPathPiece bearerIssuedBy , jwtSub = Nothing @@ -140,7 +140,7 @@ bearerToJSON BearerToken{..} = do authorityToJSON auths | [auth] <- otoList auths = either toJSON toJSON auth | otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths - iCID <- traverse I.encrypt bearerImpersonate :: m (Maybe (CryptoUUID (AuthId (HandlerSite m)))) + iCID <- traverse I.encrypt bearerImpersonate :: m (Maybe (CryptoUUID (AuthId site))) return . JSON.object $ catMaybes [ Just $ "authority" .= authorityToJSON cID diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 66ba2c906..02d46e913 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -16,6 +16,7 @@ import Model.Types.Misc as Types import Model.Types.School as Types import Model.Types.Allocation as Types import Model.Types.Languages as Types +import Model.Types.Apis as Types import Model.Types.File as Types import Model.Types.User as Types import Model.Types.Workflow as Types diff --git a/src/Model/Types/Apis.hs b/src/Model/Types/Apis.hs new file mode 100644 index 000000000..4409b1af4 --- /dev/null +++ b/src/Model/Types/Apis.hs @@ -0,0 +1,61 @@ +module Model.Types.Apis + ( ExternalApiKind(..) + , ExternalApiConfig(..) + , GradelistFormatIdent + , classifyExternalApiConfig + , module Servant.Client.Core.BaseUrl + ) where + +import Import.NoModel + +import Servant.Client.Core.BaseUrl (BaseUrl(..), Scheme(..)) + +import Data.Aeson (genericToJSON, genericParseJSON) +import Data.Swagger (SwaggerType(..), ToParamSchema(..), enum_, type_, paramSchemaToSchema, ToSchema(..), fromAesonOptions, genericDeclareNamedSchema) +import Data.Swagger.Internal.Schema (named) + +import qualified Data.HashSet as HashSet + +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + + +data ExternalApiKind = EApiKindGradelistFormat + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, Hashable) +nullaryPathPiece ''ExternalApiKind $ camelToPathPiece' 3 +pathPieceJSON ''ExternalApiKind +instance ToParamSchema ExternalApiKind where + toParamSchema _ = mempty + & type_ ?~ SwaggerString + & enum_ ?~ map toJSON (universeF @ExternalApiKind) +instance ToSchema ExternalApiKind where + declareNamedSchema = pure . named "ExternalApiKind" . paramSchemaToSchema +instance ToSample ExternalApiKind where + toSamples _ = samples universeF + +type GradelistFormatIdent = CI Text + +data ExternalApiConfig + = EApiGradelistFormat + { eapiGradelistFormats :: NonNull (HashSet GradelistFormatIdent) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) +instance ToJSON ExternalApiConfig where + toJSON = genericToJSON externalApiConfigAesonOptions +instance FromJSON ExternalApiConfig where + parseJSON = genericParseJSON externalApiConfigAesonOptions +instance ToSchema ExternalApiConfig where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiConfigAesonOptions + +derivePersistFieldJSON ''ExternalApiConfig + +instance ToSample ExternalApiConfig where + toSamples _ = gradelistFormatters + where gradelistFormatters = samples + [ EApiGradelistFormat . impureNonNull $ HashSet.singleton "Format 1" + , EApiGradelistFormat . impureNonNull $ HashSet.fromList ["Format 1", "Format 2"] + ] + +classifyExternalApiConfig :: ExternalApiConfig -> ExternalApiKind +classifyExternalApiConfig EApiGradelistFormat{} = EApiKindGradelistFormat diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index e4793092e..26fc15e46 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -9,23 +9,45 @@ module Model.Types.Security ( module Model.Types.Security ) where -import Import.NoModel +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 Control.Lens + +import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Set as Set import qualified Data.HashMap.Strict as HashMap import qualified Data.Aeson.Types as Aeson +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import Data.Set.Instances () +import Data.NonNull.Instances () +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 @@ -183,6 +205,21 @@ newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } makeLenses_ ''PredDNF +parsePredDNF :: forall a. (Ord a, PathPiece a) => PredDNF a -> [Text] -> Either Text (PredDNF a) +parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms start) + where + partition' :: Set (Set (PredLiteral a)) -> Text -> Either Text (Set (Set (PredLiteral a))) + partition' prev t + | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) + = if + | oany (authTags `Set.isSubsetOf`) prev + -> Right prev + | otherwise + -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev + | otherwise + = Left t + + $(return []) instance ToJSON a => ToJSON (PredDNF a) where @@ -198,6 +235,9 @@ type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag +defaultAuthDNF :: AuthDNF +defaultAuthDNF = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken + dnfAssumeValue :: forall a. Ord a => a -> Bool -> PredDNF a -> Maybe (PredDNF a) -- ^ `Nothing` corresponds to @⊤@ @@ -248,19 +288,23 @@ predDNFEntail = over _dnfTerms $ ofoldl' entail Set.empty data UserGroupName - = UserGroupMetrics | UserGroupCrontab + = UserGroupMetrics + | UserGroupExternalApis + | UserGroupCrontab | UserGroupCustom { userGroupCustomName :: CI Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving anyclass (Hashable, NFData) instance PathPiece UserGroupName where toPathPiece UserGroupMetrics = "metrics" + toPathPiece UserGroupExternalApis = "external-apis" toPathPiece UserGroupCrontab = "crontab" toPathPiece (UserGroupCustom t) = CI.original t fromPathPiece t = Just $ if - | "metrics" `ciEq` t -> UserGroupMetrics - | "crontab" `ciEq` t -> UserGroupCrontab - | otherwise -> UserGroupCustom $ CI.mk t + | "external-apis" `ciEq` t -> UserGroupExternalApis + | "metrics" `ciEq` t -> UserGroupMetrics + | "crontab" `ciEq` t -> UserGroupCrontab + | otherwise -> UserGroupCustom $ CI.mk t where ciEq :: Text -> Text -> Bool ciEq = (==) `on` CI.mk @@ -268,3 +312,11 @@ instance PathPiece UserGroupName where pathPieceJSON ''UserGroupName derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName makeLenses_ ''UserGroupName + +instance ToSample UserGroupName where + toSamples _ = builtins ++ samples custom + where builtins = ("Built in group", ) <$> + [ UserGroupMetrics + , UserGroupExternalApis + ] + custom = UserGroupCustom . CI.mk . ("Group " <>) . tshow <$> [1..] diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 676b64776..411e7b8b7 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -31,7 +31,7 @@ import Data.Text.Metrics (damerauLevenshtein) data SubmissionFileType = SubmissionOriginal | SubmissionCorrected deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, Hashable) nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1 diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index d545df3eb..3db76bcad 100644 --- a/src/Model/Types/TH/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -72,6 +72,37 @@ predNFAesonOptions = defaultOptions } +externalApiConfigAesonOptions :: Options +externalApiConfigAesonOptions = defaultOptions + { tagSingleConstructors = True + , unwrapUnaryRecords = False + , sumEncoding = TaggedObject "type" "config" + , allNullaryToStringTag = False + , constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + } + + +externalApiCreationRequestAesonOptions, externalApiCreationResponseAesonOptions, externalApiCreationRestrictionsAesonOptions, externalApiPongResponseAesonOptions :: Options +externalApiCreationRequestAesonOptions = defaultOptions + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 1 + } +externalApiCreationResponseAesonOptions = defaultOptions + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 1 + } +externalApiCreationRestrictionsAesonOptions = defaultOptions + { tagSingleConstructors = False + , unwrapUnaryRecords = False + , fieldLabelModifier = camelToPathPiece' 1 + } +externalApiPongResponseAesonOptions = defaultOptions + { tagSingleConstructors = False + , unwrapUnaryRecords = False + , fieldLabelModifier = camelToPathPiece' 1 + } + workflowGraphEdgeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions, workflowNodeMessageAesonOptions, workflowEdgeMessageAesonOptions :: Options workflowGraphEdgeAesonOptions = defaultOptions { constructorTagModifier = camelToPathPiece' 3 diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 34c5fca60..f7d96375e 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -429,7 +429,7 @@ data WorkflowScope termid schoolid courseid data WorkflowScope' = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse' deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) - deriving anyclass (Universe, Finite, NFData) + deriving anyclass (Hashable, Universe, Finite, NFData) classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope' classifyWorkflowScope = \case @@ -445,7 +445,7 @@ classifyWorkflowScope = \case newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) - deriving anyclass (NFData) + deriving anyclass (Hashable, NFData) instance PersistFieldSql WorkflowPayloadLabel where sqlType _ = sqlType $ Proxy @(CI Text) @@ -684,6 +684,8 @@ data WorkflowWorkflowListType = WorkflowWorkflowListActive | WorkflowWorkflowLis deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving anyclass (Universe, Finite) +instance Hashable WorkflowWorkflowListType + ----- Lenses needed here ----- diff --git a/src/Network/URI/Instances.hs b/src/Network/URI/Instances.hs index 9bd4edbe5..4b3ef50d3 100644 --- a/src/Network/URI/Instances.hs +++ b/src/Network/URI/Instances.hs @@ -5,7 +5,18 @@ module Network.URI.Instances ) where import ClassyPrelude + import Network.URI +import Network.URI.Static +import Web.HttpApiData + +import Data.Swagger +import Data.Swagger.Internal.Schema + +import Data.Proxy + +import Servant.Docs + import qualified Data.Aeson as Aeson import Control.Monad.Fail (MonadFail(..)) @@ -14,6 +25,25 @@ import Database.Persist import Database.Persist.Sql +instance ToHttpApiData URI where + toQueryParam = pack . ($ mempty) . uriToString id + +instance FromHttpApiData URI where + parseQueryParam = maybe (Left "Could not parse URIReference") Right . parseURIReference . unpack + +instance ToParamSchema URI where + toParamSchema _ = toParamSchema $ Proxy @String + +instance ToSchema URI where + declareNamedSchema = pure . named "URI" . paramSchemaToSchema + +instance ToSample URI where + toSamples _ = samples + [ [uri|https://example.invalid/path/to/resource?key1=val1&key1=val2&key2=val3#fragment|] + , [relativeReference|unAnchored/path/to/resource|] + , [relativeReference|/anchored/path/to/resource|] + ] + instance Aeson.ToJSON URI where toJSON = Aeson.String . pack . ($ mempty) . uriToString id instance Aeson.FromJSON URI where diff --git a/src/Servant/Client/Core/BaseUrl/Instances.hs b/src/Servant/Client/Core/BaseUrl/Instances.hs new file mode 100644 index 000000000..5d180736f --- /dev/null +++ b/src/Servant/Client/Core/BaseUrl/Instances.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.Client.Core.BaseUrl.Instances + () where + +import ClassyPrelude + +import Database.Persist +import Database.Persist.Sql + +import Servant.Client.Core.BaseUrl + +import qualified Data.Text.Encoding as Text + +import Control.Arrow (left) + +import Data.Swagger hiding (Scheme(..)) +import Data.Swagger.Internal.Schema (named) + +import Control.Lens + +import Servant.Docs (ToSample(..)) + + +parseBaseUrl' :: Text -> Either Text BaseUrl +parseBaseUrl' = left tshow . parseBaseUrl . unpack + +instance PersistField BaseUrl where + toPersistValue = PersistText . pack . showBaseUrl + fromPersistValue (PersistText t) = parseBaseUrl' t + fromPersistValue (PersistByteString bs) = parseBaseUrl' <=< left tshow $ Text.decodeUtf8' bs + fromPersistValue _ = Left "Unexpected type when converting to BaseUrl" + +instance PersistFieldSql BaseUrl where + sqlType _ = SqlString + +instance ToParamSchema BaseUrl where + toParamSchema _ = mempty + & type_ ?~ SwaggerString + +instance ToSchema BaseUrl where + declareNamedSchema = pure . named "BaseUrl" . paramSchemaToSchema + +instance ToSample BaseUrl where + toSamples _ + = [ ("Without path" , BaseUrl Https "example.invalid" 443 "") + , ("With path" , BaseUrl Https "example.invalid" 443 "/api") + , ("With custom port", BaseUrl Https "example.invalid" 8443 "") + ] diff --git a/src/Servant/Docs/Internal/Pretty/Instances.hs b/src/Servant/Docs/Internal/Pretty/Instances.hs new file mode 100644 index 000000000..24b761d96 --- /dev/null +++ b/src/Servant/Docs/Internal/Pretty/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.Docs.Internal.Pretty.Instances () where + +import ClassyPrelude + +import Servant.Docs.Internal.Pretty +import Servant.API.ContentTypes + +import Data.Proxy + + +instance MimeUnrender JSON a => MimeUnrender PrettyJSON a where + mimeUnrender _ = mimeUnrender $ Proxy @JSON diff --git a/src/Servant/Server/Instances.hs b/src/Servant/Server/Instances.hs new file mode 100644 index 000000000..f990bcf35 --- /dev/null +++ b/src/Servant/Server/Instances.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.Server.Instances + () where + +import ClassyPrelude hiding (Handler(..)) +import Servant.Server + +import Control.Monad.Trans.Except.Instances () + + +instance MonadUnliftIO Handler where + withRunInIO cont = Handler (withRunInIO $ \runInner -> cont (runInner . runHandler')) diff --git a/src/ServantApi.hs b/src/ServantApi.hs new file mode 100644 index 000000000..e4a66c1bd --- /dev/null +++ b/src/ServantApi.hs @@ -0,0 +1,14 @@ +module ServantApi + ( module ServantApi + ) where + +import Import.Servant + + +import ServantApi.ExternalApis as ServantApi + + +mkYesodApi ''UniWorX uniworxRoutes + +uniworxApi :: Proxy UniWorXApi +uniworxApi = Proxy diff --git a/src/ServantApi/ExternalApis.hs b/src/ServantApi/ExternalApis.hs new file mode 100644 index 000000000..96647dbed --- /dev/null +++ b/src/ServantApi/ExternalApis.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ServantApi.ExternalApis + ( module ServantApi.ExternalApis.Type + ) where + +import Import.Servant + +import ServantApi.ExternalApis.Type + +import qualified Data.HashSet as HashSet + + +instance ServantApiDispatchUniWorX ExternalApis where + servantServer' _ = genericServerT ExternalApis + { externalApisListR = externalApisList + , externalApisCreateR = externalApiCreate + , externalApisInfoR = externalApiInfo + , externalApisPongR = externalApiPong + , externalApisDeleteR = externalApiDelete + } + +externalApisList :: ServantHandler ExternalApisList +externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive] + where + toResponse :: [Entity ExternalApi] -> ServantHandler (HashMap CryptoUUIDExternalApi ExternalApiInfo) + toResponse = foldMapM $ fmap (uncurry singletonMap) . toResponse' + + toResponse' :: Entity ExternalApi -> ServantHandler (CryptoUUIDExternalApi, ExternalApiInfo) + toResponse' (Entity eApiId eApi) = (,) <$> encrypt eApiId <*> dbToInfo eApi + +externalApiCreate :: Maybe ExternalApiCreationRestrictions + -> BearerToken UniWorX + -> ExternalApiCreationRequest + -> ServantHandler (Headers '[Header "Location" URI] ExternalApiCreationResponse) +externalApiCreate mRestr bearer ExternalApiCreationRequest{..} = do + now <- liftIO getCurrentTime + + unless (maybe True matchesRequest mRestr) $ + throwError err403{ errBody = "Bearer restrictions do not permit request" } + + jwt <- encodeBearer bearer + + Entity apiId api <- runDB $ upsert ExternalApi + { externalApiIdent = mRestr >>= eacrIdent + , externalApiAuthority = jwt + , externalApiKeys = eacrPublicKeys & _keys %~ filter (not . isPrivateJwk) + , externalApiBaseUrl = eacrBaseUrl + , externalApiConfig = eacrConfig + , externalApiLastAlive = now + } + [ ExternalApiAuthority =. jwt + , ExternalApiKeys =. (eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)) + , ExternalApiBaseUrl =. eacrBaseUrl + , ExternalApiConfig =. eacrConfig + , ExternalApiLastAlive =. now + ] + eacrId <- encrypt apiId + + location <- renderRouteAbsolute . ExternalApisR $ servantApiLink (Proxy @ExternalApis) (Proxy @ExternalApisInfoR) eacrId + + eacrInfo <- set _eaiPublicKeys (eacrPublicKeys & _keys %~ filter (not . isPrivateJwk)) <$> dbToInfo api + + return $ addHeader location ExternalApiCreationResponse + { eacrId + , eacrInfo + } + + where + matchesRequest ExternalApiCreationRestrictions{..} = and + [ classifyExternalApiConfig eacrConfig `elem` eacrApiKinds + ] + +externalApiInfo :: ExternalApiId -> ServantHandler ExternalApiInfo +externalApiInfo apiId = + dbToInfo <=< runDB $ get apiId >>= maybe (throwError err404) return + +externalApiPong :: ExternalApiId -> ServantHandler ExternalApiPongResponse +externalApiPong apiId = do + now <- liftIO getCurrentTime + ExternalApi{..} <- runDB $ do + unlessM (existsKey apiId) $ throwError err404 + updateGet apiId [ ExternalApiLastAlive =. now ] + + return $ ExternalApiPongResponse externalApiLastAlive + +externalApiDelete :: ExternalApiId -> ServantHandler NoContent +externalApiDelete apiId = NoContent <$ runDB (delete apiId) + + +dbToInfo :: ExternalApi -> ServantHandler ExternalApiInfo +dbToInfo ExternalApi{..} = do + BearerToken{..} <- decodeBearer externalApiAuthority + eaiTokenAuthority <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . encrypt)) bearerAuthority + let eaiTokenIssued = bearerIssuedAt + eaiTokenExpiresAt = bearerExpiresAt + eaiTokenStartsAt = bearerStartsAt + + eaiPublicKeys = externalApiKeys & _keys %~ filter isPublicJwk + + eaiBaseUrl = externalApiBaseUrl + + eaiLastAlive = externalApiLastAlive + + eaiConfig = externalApiConfig + + eaiIdent = externalApiIdent + + return ExternalApiInfo{..} diff --git a/src/ServantApi/ExternalApis/Type.hs b/src/ServantApi/ExternalApis/Type.hs new file mode 100644 index 000000000..4a1b6be51 --- /dev/null +++ b/src/ServantApi/ExternalApis/Type.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ServantApi.ExternalApis.Type where + +import Import.Servant.NoFoundation hiding ((.=), keys) + +import Data.Aeson + +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict.InsOrd as HashMap.InsOrd + +import Jose.Jwk (JwkSet(..)) + +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + + +type ExternalApisListR = ApiVersion 1 0 0 + :> Get '[PrettyJSON] ExternalApisList +type ExternalApisCreateR = ApiVersion 1 0 0 + :> CaptureBearerRestriction' '[Optional] ExternalApiCreationRestrictions + :> CaptureBearerToken + :> ReqBody '[JSON] ExternalApiCreationRequest + :> PostCreated '[PrettyJSON] (Headers '[Header "Location" URI] ExternalApiCreationResponse) +type ExternalApisPongR = ApiVersion 1 0 0 + :> CaptureCryptoUUID "external-api" ExternalApiId + :> "pong" + :> Post '[PrettyJSON] ExternalApiPongResponse +type ExternalApisInfoR = ApiVersion 1 0 0 + :> CaptureCryptoUUID "external-api" ExternalApiId + :> Get '[PrettyJSON] ExternalApiInfo +type ExternalApisDeleteR = ApiVersion 1 0 0 + :> CaptureCryptoUUID "external-api" ExternalApiId + :> DeleteNoContent + +data ExternalApis mode = ExternalApis + { externalApisListR :: mode :- ExternalApisListR + , externalApisCreateR :: mode :- ExternalApisCreateR + , externalApisInfoR :: mode :- ExternalApisInfoR + , externalApisPongR :: mode :- ExternalApisPongR + , externalApisDeleteR :: mode :- ExternalApisDeleteR + } deriving (Generic) + +type ServantApiExternalApis = ServantApi ExternalApis +type instance ServantApiUnproxy ExternalApis = ToServantApi ExternalApis + + +instance ToCapture (Capture "external-api" UUID) where + toCapture _ = DocCapture "external-api" "Internal id of the registered external api" + + +data ExternalApiCreationRequest = ExternalApiCreationRequest + { eacrPublicKeys :: JwkSet + , eacrBaseUrl :: BaseUrl + , eacrConfig :: ExternalApiConfig + } deriving (Eq, Show, Generic, Typeable) + +instance ToJSON ExternalApiCreationRequest where + toJSON = genericToJSON externalApiCreationRequestAesonOptions +instance FromJSON ExternalApiCreationRequest where + parseJSON = genericParseJSON externalApiCreationRequestAesonOptions +instance ToSchema ExternalApiCreationRequest where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiCreationRequestAesonOptions +instance ToSample ExternalApiCreationRequest + +data ExternalApiCreationResponse = ExternalApiCreationResponse + { eacrId :: CryptoUUIDExternalApi + , eacrInfo :: ExternalApiInfo + } deriving (Eq, Show, Generic, Typeable) + +instance ToJSON ExternalApiCreationResponse where + toJSON = genericToJSON externalApiCreationResponseAesonOptions +instance FromJSON ExternalApiCreationResponse where + parseJSON = genericParseJSON externalApiCreationResponseAesonOptions +instance ToSchema ExternalApiCreationResponse where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiCreationResponseAesonOptions +instance ToSample ExternalApiCreationResponse where + toSamples _ = samples $ ExternalApiCreationResponse + <$> fmap (unTagged . snd) (toSamples $ Proxy @(Tagged ExternalApiId CryptoUUIDExternalApi)) + <*> fmap snd (toSamples $ Proxy @ExternalApiInfo) + +data ExternalApiCreationRestrictions = ExternalApiCreationRestrictions + { eacrIdent :: Maybe UUID + , eacrApiKinds :: NonNull (HashSet ExternalApiKind) + } deriving (Eq, Show, Generic, Typeable) +instance ToJSON ExternalApiCreationRestrictions where + toJSON = genericToJSON externalApiCreationRestrictionsAesonOptions +instance FromJSON ExternalApiCreationRestrictions where + parseJSON = genericParseJSON externalApiCreationRestrictionsAesonOptions +instance ToSchema ExternalApiCreationRestrictions where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiCreationRestrictionsAesonOptions +instance ToSample ExternalApiCreationRestrictions + + +data ExternalApiPongResponse = ExternalApiPongResponse + { eaprLastAlive :: UTCTime + } deriving (Eq, Show, Generic, Typeable) +instance ToJSON ExternalApiPongResponse where + toJSON = genericToJSON externalApiPongResponseAesonOptions +instance FromJSON ExternalApiPongResponse where + parseJSON = genericParseJSON externalApiPongResponseAesonOptions +instance ToSchema ExternalApiPongResponse where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions externalApiPongResponseAesonOptions +instance ToSample ExternalApiPongResponse + + +newtype ExternalApisList = ExternalApisList (HashMap CryptoUUIDExternalApi ExternalApiInfo) + deriving (Eq, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON, ToSchema) + +instance ToSample ExternalApisList where + toSamples _ = samples $ map (\n -> ExternalApisList . fold $ take n singletons) [0..] + where + singletons = zipWith (\(_, Tagged s) (_, s') -> singletonMap s s') (toSamples $ Proxy @(Tagged ExternalApiId CryptoUUIDExternalApi)) (toSamples $ Proxy @ExternalApiInfo) + + +data ExternalApiInfo = ExternalApiInfo + { eaiIdent :: Maybe UUID + , eaiTokenAuthority :: HashSet (Either Value CryptoUUIDUser) + , eaiTokenIssued :: UTCTime + , eaiTokenExpiresAt, eaiTokenStartsAt :: Maybe UTCTime + , eaiPublicKeys :: JwkSet + , eaiBaseUrl :: BaseUrl + , eaiLastAlive :: UTCTime + , eaiConfig :: ExternalApiConfig + } deriving (Eq, Show, Generic, Typeable) + +instance ToJSON ExternalApiInfo where + toJSON ExternalApiInfo{..} = object $ maybe id ((:) . ("ident" .=)) eaiIdent + [ "token-authority" .= case HashSet.toList eaiTokenAuthority of + [x] -> either id toJSON x + _ -> toJSON $ foldMap (HashSet.singleton . either id toJSON) eaiTokenAuthority + , "token-issued" .= eaiTokenIssued + , "token-expires-at" .= eaiTokenExpiresAt + , "token-starts-at" .= eaiTokenStartsAt + , "public-keys" .= keys eaiPublicKeys + , "base-url" .= eaiBaseUrl + , "last-alive" .= eaiLastAlive + , "config" .= eaiConfig + ] + +instance FromJSON ExternalApiInfo where + parseJSON = withObject "ExternalApiInfo" $ \o -> do + eaiIdent <- o .:? "ident" + eaiTokenAuthority <- asum + [ HashSet.singleton . Right <$> o .: "token-authority" + , (o .: "token-authority" :: _ (HashSet Value)) >>= foldMapM (\v' -> fmap HashSet.singleton $ (Right <$> parseJSON v') <|> return (Left v')) + , HashSet.singleton . Left <$> o .: "token-authority" + ] + eaiTokenIssued <- o .: "token-issued" + eaiTokenExpiresAt <- o .: "token-expires-at" + eaiTokenStartsAt <- o .: "token-starts-at" + eaiPublicKeys <- JwkSet <$> o .: "public-keys" + eaiBaseUrl <- o .: "base-url" + eaiLastAlive <- o .: "last-alive" + eaiConfig <- o .: "config" + return ExternalApiInfo{..} + +instance ToSchema ExternalApiInfo where + declareNamedSchema _ = do + utcTimeSchema <- declareSchemaRef $ Proxy @UTCTime + jwkSetSchema <- declareSchemaRef $ Proxy @[Jwk] + baseUrlSchema <- declareSchemaRef $ Proxy @BaseUrl + externalApiConfigSchema <- declareSchemaRef $ Proxy @ExternalApiConfig + uuidSchema <- declareSchemaRef $ Proxy @UUID + + pure . named "ExternalApiInfo" $ mempty + & type_ ?~ SwaggerObject + & properties .~ mconcat + [ HashMap.InsOrd.singleton "ident" uuidSchema + , HashMap.InsOrd.singleton "token-authority" $ Inline mempty + , HashMap.InsOrd.singleton "token-issued" utcTimeSchema + , HashMap.InsOrd.singleton "token-expires-at" utcTimeSchema + , HashMap.InsOrd.singleton "token-starts-at" utcTimeSchema + , HashMap.InsOrd.singleton "public-keys" jwkSetSchema + , HashMap.InsOrd.singleton "base-url" baseUrlSchema + , HashMap.InsOrd.singleton "last-alive" utcTimeSchema + , HashMap.InsOrd.singleton "config" externalApiConfigSchema + ] + & required .~ ["token-authority", "token-issued", "token-expires-at", "token-starts-at", "public-keys", "base-url", "last-alive", "config"] + +instance ToSample ExternalApiInfo where + toSamples _ = samples $ do + (_, eaiIdent) <- toSamples Proxy + + let eaiTokenAuthority' = do + specificUser <- [False, True] + if | specificUser -> Right <$> map (unTagged . snd) (toSamples $ Proxy @(Tagged UserId CryptoUUIDUser)) + | otherwise -> Left <$> map (toJSON . snd) (toSamples $ Proxy @UserGroupName) + eaiTokenAuthority <- fmap HashSet.fromList $ flip replicateM eaiTokenAuthority' =<< [0..] + + (_, eaiTokenIssued) <- toSamples Proxy + (_, eaiTokenExpiresAt) <- toSamples Proxy + (_, eaiTokenStartsAt) <- toSamples Proxy + (_, eaiLastAlive) <- toSamples Proxy + + -- If times didn't match up this instance could not have registered + guard $ NTop (Just eaiTokenIssued) <= NTop eaiTokenExpiresAt + guard $ NTop (Just <$> eaiTokenExpiresAt) >= NTop (Just eaiTokenStartsAt) + guard $ eaiLastAlive >= eaiTokenIssued + && Just eaiLastAlive >= eaiTokenStartsAt + && NTop (Just eaiLastAlive) <= NTop eaiTokenExpiresAt + + (_, eaiBaseUrl) <- toSamples Proxy + (_, eaiConfig) <- toSamples Proxy + + (_, eaiPublicKeys) <- toSamples Proxy + & traverse . _2 . _keys %~ filter isPublicJwk + + return ExternalApiInfo{..} + + +isPublicJwk, isPrivateJwk :: Jwk -> Bool +isPublicJwk RsaPublicJwk{} = True +isPublicJwk EcPublicJwk{} = True +isPublicJwk _ = False +isPrivateJwk RsaPrivateJwk{} = True +isPrivateJwk EcPrivateJwk{} = True +isPrivateJwk _ = False + + +makeLenses_ ''ExternalApiInfo diff --git a/src/Settings.hs b/src/Settings.hs index 1195e1578..d21ef70a6 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -184,6 +184,10 @@ data AppSettings = AppSettings , appUserDefaults :: UserDefaultConf , appAuthPWHash :: PWHashConf + , appExternalApisPingInterval + , appExternalApisPongTimeout + , appExternalApisExpiry :: NominalDiffTime + , appCookieSettings :: RegisteredCookie -> CookieSettings , appMemcachedConf :: Maybe MemcachedConf @@ -657,6 +661,9 @@ instance FromJSON AppSettings where appSessionTokenExpiration <- o .:? "session-token-expiration" appSessionTokenEncoding <- o .: "session-token-encoding" + appExternalApisPingInterval <- o .: "external-apis-ping-interval" + appExternalApisPongTimeout <- o .: "external-apis-pong-timeout" + appExternalApisExpiry <- o .: "external-apis-expiry" appSessionTokenClockLeniencyStart <- o .:? "session-token-clock-leniency-start" appSessionTokenClockLeniencyEnd <- o .:? "session-token-clock-leniency-end" diff --git a/src/Utils.hs b/src/Utils.hs index 2a2e2ae23..5089f4ed2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -113,7 +113,9 @@ import Data.Binary (Binary) import qualified Data.Binary as Binary import Network.Wai (requestMethod) -import Network.HTTP.Types.Header +import Network.HTTP.Types.Header as Wai + +import Web.HttpApiData import Data.Time.Clock @@ -226,7 +228,6 @@ instance ToMarkup YamlValue where toYAML :: ToJSON a => a -> YamlValue toYAML = YamlValue . toJSON - delimitInternalState :: forall site a. HandlerFor site a -> HandlerFor site a -- | Switches the `InternalState` contained within the environment of `HandlerFor` to new one created with `bracket` -- @@ -783,6 +784,9 @@ throwLeft = either throwM return maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b maybeExceptT err act = lift act >>= maybe (throwE err) return + +maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b +maybeExceptT' err = maybe (throwE err) return maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return @@ -1144,6 +1148,9 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload) replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload) +waiCustomHeader :: ToHttpApiData payload => CustomHeader -> payload -> Wai.Header +waiCustomHeader ident payload = (CI.mk . encodeUtf8 $ toPathPiece ident, toHeader payload) + ------------------ -- HTTP Headers -- ------------------ diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8464e5b36..5396ff690 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -250,6 +250,8 @@ makeLenses_ ''ExternalExamOfficeSchool makeLenses_ ''ExternalExamStaff makeLenses_ ''ExternalExamResult +makeLenses_ ''JwkSet + makeLenses_ ''Rating makeLenses_ ''Rating' diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index e072148d2..c6f0229eb 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -32,44 +32,45 @@ import CryptoID import Text.Blaze (Markup) -bearerParseJSON' :: forall m. - ( Hashable (AuthId (HandlerSite m)), Eq (AuthId (HandlerSite m)) - , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser) - , ParseRoute (HandlerSite m) - , Hashable (Route (HandlerSite m)) - , MonadHandler m +bearerParseJSON' :: forall site m. + ( Hashable (AuthId site), Eq (AuthId site) + , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser) + , ParseRoute site + , Hashable (Route site) + , MonadSite site m , MonadCrypto m , MonadCryptoKey m ~ CryptoIDKey ) - => m (Value -> Parser (BearerToken (HandlerSite m))) + => m (Value -> Parser (BearerToken site)) -- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s bearerParseJSON' = do cidKey <- cryptoIDKey return return $ flip runReaderT cidKey . bearerParseJSON -bearerToken :: forall m. - ( MonadHandler m - , HasInstanceID (HandlerSite m) InstanceId - , HasClusterID (HandlerSite m) ClusterId - , HasAppSettings (HandlerSite m) +bearerToken :: forall site m. + ( MonadSite site m + , MonadIO m + , HasInstanceID site InstanceId + , HasClusterID site ClusterId + , HasAppSettings site ) - => HashSet (Either Value (AuthId (HandlerSite m))) -- ^ Authority - -> Maybe (AuthId (HandlerSite m)) -- ^ Impersonate - -> HashMap BearerTokenRouteMode (HashSet (Route (HandlerSite m))) + => HashSet (Either Value (AuthId site)) -- ^ Authority + -> Maybe (AuthId site) -- ^ Impersonate + -> HashMap BearerTokenRouteMode (HashSet (Route site)) -> Maybe AuthDNF -- ^ Additional auth -> Maybe (Maybe UTCTime) -- ^ Expiration; @Nothing@ determines default expiry time automatically -> Maybe UTCTime -- ^ Start of Validity; @Nothing@ means token starts to be valid immediately - -> m (BearerToken (HandlerSite m)) + -> m (BearerToken site) -- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict` bearerToken bearerAuthority bearerImpersonate bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do bearerIdentifier <- liftIO getRandom bearerIssuedAt <- liftIO getCurrentTime - bearerIssuedBy <- getsYesod $ view instanceID - bearerIssuedFor <- getsYesod $ view clusterID - - defaultExpiration <- getsYesod $ view _appBearerExpiration + bearerIssuedBy <- getsSite $ view instanceID + bearerIssuedFor <- getsSite $ view clusterID + defaultExpiration <- getsSite $ view _appBearerExpiration + let bearerExpiresAt | Just t <- mBearerExpiresAt = t @@ -82,19 +83,20 @@ bearerToken bearerAuthority bearerImpersonate bearerRoutes bearerAddAuth mBearer return BearerToken{..} -encodeBearer :: forall m. - ( MonadHandler m - , HasJSONWebKeySet (HandlerSite m) JwkSet - , HasAppSettings (HandlerSite m) - , HasCryptoUUID (AuthId (HandlerSite m)) m - , RenderRoute (HandlerSite m) +encodeBearer :: forall site m. + ( MonadSite site m + , MonadIO m + , HasJSONWebKeySet site JwkSet + , HasAppSettings site + , HasCryptoUUID (AuthId site) m + , RenderRoute site ) - => BearerToken (HandlerSite m) -> m Jwt + => BearerToken site -> m Jwt -- ^ Call `bearerToJSON` and encode the result as a `Jwt` according to `appJwtEncoding` encodeBearer token = do payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token - JwkSet jwks <- getsYesod $ view jsonWebKeySet - jwtEncoding <- getsYesod $ view _appBearerEncoding + JwkSet jwks <- getsSite $ view jsonWebKeySet + jwtEncoding <- getsSite $ view _appBearerEncoding throwLeft =<< liftIO (Jose.encode jwks jwtEncoding payload) @@ -106,23 +108,24 @@ data BearerTokenException deriving (Eq, Show, Generic, Typeable) deriving anyclass (Exception) -decodeBearer :: forall m. - ( MonadHandler m - , HasJSONWebKeySet (HandlerSite m) JwkSet - , Hashable (AuthId (HandlerSite m)), Eq (AuthId (HandlerSite m)) - , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser) +decodeBearer :: forall site m. + ( MonadSite site m + , MonadIO m + , HasJSONWebKeySet site JwkSet + , Hashable (AuthId site), Eq (AuthId site) + , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser) , MonadCryptoKey m ~ CryptoIDKey , MonadCrypto m - , ParseRoute (HandlerSite m) - , Hashable (Route (HandlerSite m)) - , HasAppSettings (HandlerSite m), HasClusterID (HandlerSite m) ClusterId + , ParseRoute site + , Hashable (Route site) + , HasAppSettings site, HasClusterID site ClusterId ) - => Jwt -> m (BearerToken (HandlerSite m)) + => Jwt -> m (BearerToken site) -- ^ Decode a `Jwt` and call `bearerParseJSON` -- -- Throws `BearerTokenException`s decodeBearer (Jwt bs) = do - JwkSet jwks <- getsYesod $ view jsonWebKeySet + JwkSet jwks <- getsSite $ view jsonWebKeySet content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs) content' <- case content of Jose.Unsecured _ -> throwM BearerTokenUnsecured @@ -130,11 +133,11 @@ decodeBearer (Jwt bs) = do Jose.Jwe (_header, payload) -> return payload parser <- bearerParseJSON' bearer@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content' - bearerIssuedFor' <- getsYesod $ view clusterID + bearerIssuedFor' <- getsSite $ view clusterID unless (bearerIssuedFor' == bearerIssuedFor) $ throwM BearerTokenWrongAudience now <- liftIO getCurrentTime - (clockLeniencyStart, clockLeniencyEnd) <- getsYesod $ (,) <$> view _appBearerTokenClockLeniencyStart <*> view _appBearerTokenClockLeniencyEnd + (clockLeniencyStart, clockLeniencyEnd) <- getsSite $ (,) <$> view _appBearerTokenClockLeniencyStart <*> view _appBearerTokenClockLeniencyEnd unless (NTop bearerExpiresAt > NTop (Just $ maybe id addUTCTime (negate <$> clockLeniencyEnd) now)) $ throwM BearerTokenExpired unless (bearerStartsAt <= Just (maybe id addUTCTime clockLeniencyStart now)) $ @@ -142,7 +145,7 @@ decodeBearer (Jwt bs) = do return bearer -askBearer :: forall m. ( MonadHandler m ) +askBearer :: forall m. MonadHandler m => m (Maybe Jwt) -- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter askBearer = runMaybeT $ asum diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index 76e480a8f..9ffdca574 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -71,9 +71,6 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where put = Binary.put . toPathPiece get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece -instance RenderRoute site => Hashable (Route site) where - hashWithSalt s = hashWithSalt s . routeToPathPiece - instance Monad FormResult where (FormSuccess a) >>= f = f a diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs new file mode 100644 index 000000000..3abe2732d --- /dev/null +++ b/src/Yesod/Servant.hs @@ -0,0 +1,592 @@ +{-# OPTIONS_GHC -fno-warn-unused-foralls #-} +{-# LANGUAGE UndecidableInstances #-} + +module Yesod.Servant + ( ServantApiUnproxy, ServantApiUnproxy', ServantApiDirect + , HasRoute(..) + , ServantApi(..), getServantApi + , ServantApiDispatch(..) + , servantApiLink + , ServantHandlerFor(..) + , HasServantHandlerContext(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute, servantApiBaseUrl + , MonadServantHandler(..), MonadHandler(..), MonadSite(..), MonadRequest(..) + , ServantDBFor, ServantPersist(..), defaultRunDB + , ServantLog(..), ServantLogYesod(..) + , mkYesodApi + , PathPieceHttpApiData(..) + , BearerAuth, SessionAuth + , ServantErrorResponse, getServantErrorResponse + , module Yesod.Servant.HttpApiDataInjective + ) where + +import ClassyPrelude hiding (Handler, fromList, link) +import Control.Lens hiding (Context) +import Control.Lens.Extras + +import Foundation.Servant.Types + +import Utils hiding (HasRoute) +import Model.Types.Security + +import Yesod.Core ( Yesod + , RenderRoute(..), ParseRoute(..) + , YesodSubDispatch(..) + , PathPiece(..) + ) +import Yesod.Core.Types ( YesodRunnerEnv(..) + , YesodSubRunnerEnv(..) + ) +import qualified Yesod.Core as Yesod +import qualified Yesod.Core.Types as Yesod +import qualified Yesod.Persist.Core as Yesod + +import Servant.Links +import Servant.API +import Servant.Server hiding (route) +import Servant.Server.Instances () + +import Servant.Client.Core.BaseUrl + +import Data.Proxy + +import Network.Wai (Request, Middleware) +import qualified Network.Wai as W + +import Language.Haskell.TH hiding (Type) +import qualified Language.Haskell.TH as TH (Type) +import Language.Haskell.Meta.Parse (parseType) +import Yesod.Routes.TH.Types + +import Control.Monad.Fail (MonadFail(..)) + +import Data.Data (Data) +import Data.Kind (Type) +import GHC.Exts (Constraint) + +import Data.Swagger + +import qualified Data.Set as Set + +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI + +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Catch (MonadThrow(..), MonadCatch, MonadMask) +import Control.Monad.Base (MonadBase) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Error.Class (MonadError) + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Text.Lens (packed) + +import Data.Typeable (eqT, typeRep) + +import Network.URI +import Network.URI.Lens +import GHC.TypeLits (KnownSymbol, symbolVal, KnownNat) + +import Text.Read (Read(readPrec), readP_to_Prec, readPrec_to_P) +import Text.Show (showParen, showString) +import qualified Text.ParserCombinators.ReadP as R +import qualified Data.Char as Char + +import Yesod.Servant.HttpApiDataInjective + +import qualified Data.ByteString.Base64.URL as Base64 (encode) +import qualified Data.Binary.Builder as Builder + +import Database.Persist + +import Data.CryptoID.Class.ImplicitNamespace + +import Control.Monad.Logger + + +renderServantRoute :: Link -> ([Text], [(Text, Text)]) +renderServantRoute link + = ( linkSegments link <&> pack . unEscapeString + , linkQueryParams link <&> paramToPair + ) + where paramToPair (FlagParam str ) = (pack $ unEscapeString str, Text.empty) + paramToPair (ArrayElemParam str val) = (pack $ unEscapeString str, val ) + paramToPair (SingleParam str val) = (pack $ unEscapeString str, val ) + + +escapedSymbol :: forall sym. KnownSymbol sym => Proxy sym -> Text +escapedSymbol _ = pack . escapeURIString isUnreserved . symbolVal $ Proxy @sym + +class HasLink api => HasRoute api where + parseServantRoute :: forall proxy. ServantApiUnproxy' proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy)) + +instance HasRoute EmptyAPI where + parseServantRoute _ = Nothing + +instance (Typeable m, Typeable k) => HasRoute (NoContentVerb (m :: k)) where + parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(NoContentVerb m)) id mempty mempty + parseServantRoute _ = Nothing + +instance (Typeable m, Typeable k, Typeable s, Typeable ct, Typeable a, IsSubList ct ct ~ (() :: Constraint)) => HasRoute (Verb (m :: k) s ct a) where + parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Verb m s ct a)) id mempty mempty + parseServantRoute _ = Nothing + +instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typeable a) => HasRoute (Stream (m :: k) status fr ct a) where + parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Stream m status fr ct a)) id mempty mempty + parseServantRoute _ = Nothing + +instance HasRoute sub => HasRoute (HttpVersion :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(HttpVersion :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance HasRoute sub => HasRoute (Vault :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Vault :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, KnownSymbol realm, Typeable a) => HasRoute (BasicAuth realm a :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(BasicAuth realm a :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, KnownSymbol s) => HasRoute (Description s :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Description s :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, KnownSymbol s) => HasRoute (Summary s :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Summary s :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, Typeable tag, Typeable k) => HasRoute (AuthProtect (tag :: k) :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(AuthProtect tag :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance HasRoute sub => HasRoute (IsSecure :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(IsSecure :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance HasRoute sub => HasRoute (RemoteHost :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(RemoteHost :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, Typeable mods, Typeable restr) => HasRoute (CaptureBearerRestriction' mods restr :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerRestriction' mods restr :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, Typeable mods) => HasRoute (CaptureBearerToken' mods :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerToken' mods :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (KnownSymbol sym, HasRoute sub, HasLink sub) => HasRoute (sym :> sub) where + parseServantRoute (p : ps, qs) + | p == escapedSymbol (Proxy @sym) + = parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(sym :> endpoint)) f (escapedSymbol (Proxy @sym) : ps') qs' + ServantApiBaseRoute -> ServantApiBaseRoute + parseServantRoute _ = Nothing + +instance (HasRoute a, HasRoute b) => HasRoute (a :<|> b) where + parseServantRoute args = asum + [ parseServantRoute @a @(ServantApiDirect a) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + , parseServantRoute @b @(ServantApiDirect b) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + ] + +instance (HasRoute sub, Typeable mods, Typeable ct, Typeable a) => HasRoute (ReqBody' mods ct a :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ReqBody' mods ct a :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, Typeable mods, Typeable framing, Typeable ct, Typeable a) => HasRoute (StreamBody' mods framing ct a :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(StreamBody' mods framing ct a :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: Type) :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Header' mods sym a :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + +instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable v, ToHttpApiDataInjective v, FromHttpApiData v) => HasRoute (Capture' mods sym (v :: Type) :> sub) where + parseServantRoute (p : ps, qs) + | Right v <- parseUrlPiece @v p + = parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(Capture' mods sym v :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs' + ServantApiBaseRoute -> ServantApiBaseRoute + parseServantRoute _ = Nothing + +instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHttpApiDataInjective ciphertext, FromHttpApiData ciphertext, Typeable ciphertext) => HasRoute (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where + parseServantRoute (p : ps, qs) + | Right v <- parseUrlPiece @(CryptoID ciphertext plaintext) p + = parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs' + ServantApiBaseRoute -> ServantApiBaseRoute + parseServantRoute _ = Nothing + +instance (HasRoute sub, KnownNat major, KnownNat minor, KnownNat patch) => HasRoute (ApiVersion major minor patch :> sub) where + parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case + ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ApiVersion major minor patch :> endpoint)) f ps qs + ServantApiBaseRoute -> ServantApiBaseRoute + + +data ServantApi (proxy :: k) = ServantApi + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Hashable) + +getServantApi :: forall master proxy. master -> ServantApi proxy +getServantApi _ = ServantApi + +type family ServantApiUnproxy (proxy :: k) :: Type + +type ServantApiUnproxy' :: forall k. forall (proxy :: k) -> Type +type family ServantApiUnproxy' proxy where + ServantApiUnproxy' @Type (ServantApiDirect api) = api + ServantApiUnproxy' @k' proxy = ServantApiUnproxy proxy + +data ServantApiDirect (api :: Type) +type instance ServantApiUnproxy (ServantApiDirect api) = api + +instance HasRoute (ServantApiUnproxy' proxy) => RenderRoute (ServantApi proxy) where + data Route (ServantApi proxy) + = forall endpoint. + ( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint) + , HasRoute endpoint + , Typeable endpoint + ) + => ServantApiRoute + (Proxy endpoint) + (forall a. MkLink endpoint a -> a) + [Text] (HashMap Text [Text]) + | ServantApiBaseRoute + renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint) + renderRoute ServantApiBaseRoute = mempty + +instance HasRoute (ServantApiUnproxy' proxy) => Eq (Route (ServantApi proxy)) where + (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) == (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs') + = case eqT @endpoint @endpoint' of + Just Refl -> ps == ps' && qs == qs' + Nothing -> False + ServantApiBaseRoute == ServantApiBaseRoute = True + _ == _ = False + +instance HasRoute (ServantApiUnproxy' proxy) => Ord (Route (ServantApi proxy)) where + compare (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs') + = case eqT @endpoint @endpoint' of + Just Refl -> compare ps ps' <> compare qs qs' + Nothing -> typeRep (Proxy @endpoint) `compare` typeRep (Proxy @endpoint') + compare ServantApiBaseRoute ServantApiBaseRoute = EQ + compare ServantApiBaseRoute _ = LT + compare _ ServantApiBaseRoute = GT + +instance HasRoute (ServantApiUnproxy' proxy) => Hashable (Route (ServantApi proxy)) where + hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` (0 :: Int) `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs + hashWithSalt salt ServantApiBaseRoute = salt `hashWithSalt` (1 :: Int) + +instance HasRoute (ServantApiUnproxy' proxy) => Read (Route (ServantApi proxy)) where + readPrec = readP_to_Prec $ \d -> asum + [ ServantApiBaseRoute <$ R.string "ServantApiBaseRoute" + , do + when (d > 10) . void $ R.char '(' + R.skipSpaces + void $ R.string "ServantApiRoute " + R.skipSpaces + void $ R.string "_ " + R.skipSpaces + asum [ do + void $ R.char '(' + R.skipMany . R.manyTill (R.satisfy $ const True) $ R.char ')' + void $ R.char ' ' + , R.skipMany . R.manyTill (R.satisfy $ not . Char.isSpace) $ R.satisfy Char.isSpace + ] + R.skipSpaces + ps <- readPrec_to_P readPrec 11 + void $ R.char ' ' + R.skipSpaces + qs <- readPrec_to_P readPrec 11 :: R.ReadP (HashMap Text [Text]) + R.skipSpaces + when (d > 10) . void $ R.char ')' + maybe (fail "Could not parse servant route") return $ parseServantRoute (ps, ifoldMap (fmap . (,)) qs) + ] +instance HasRoute (ServantApiUnproxy' proxy) => Show (Route (ServantApi proxy)) where + showsPrec d (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = showParen (d > 10) + $ showString "ServantApiRoute " + . showsPrec 11 (typeRep $ Proxy @endpoint) + . showString " _ " + . showsPrec 11 ps + . showString " " + . showsPrec 11 qs + showsPrec _ ServantApiBaseRoute = showString "ServantApiBaseRoute" + +instance HasRoute (ServantApiUnproxy' proxy) => ParseRoute (ServantApi proxy) where + parseRoute = parseServantRoute + +newtype ServantErrorResponse + = ServantErrorResponse { getServantErrorResponse :: W.Response } + +class (HasServer (ServantApiUnproxy' proxy) context, HasRoute (ServantApiUnproxy' proxy), HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) => ServantApiDispatch context m master proxy | master proxy -> context m where + servantContext :: ServantApi proxy -> master -> Request -> Yesod.HandlerFor master (Context context) + servantHoist :: ServantApi proxy -> master -> Request -> Context context -> (forall a. m a -> Handler a) + servantMiddleware :: ServantApi proxy -> master -> Context context -> Middleware + servantYesodMiddleware :: ServantApi proxy -> master -> Yesod.HandlerFor master Middleware + servantServer :: ServantApi proxy -> master -> ServerT (ServantApiUnproxy' proxy) m + +instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantApi proxy) master where + yesodSubDispatch YesodSubRunnerEnv{..} req + = ysreParentRunner handlerT ysreParentEnv (ysreToParentRoute <$> route) req + where + master :: master + master = yreSite ysreParentEnv + proxy :: ServantApi proxy + proxy = ysreGetSub master + + route = parseRoute ( W.pathInfo req + , over (traverse . _2) (fromMaybe Text.empty) . queryToQueryText $ W.queryString req + ) + + handlerT :: Yesod.HandlerFor master Yesod.TypedContent + handlerT = do + yesodMiddleware <- servantYesodMiddleware proxy master + ctx <- servantContext proxy master req + + let server' = hoistServerWithContext (Proxy @(ServantApiUnproxy' proxy)) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master) + toTypedContent = error "Servant handler did not shortcircuit" + sendResponse res = case yesodError of + Just err -> do + Yesod.cacheSet $ ServantErrorResponse res + throwM . Yesod.HCError =<< liftIO (err <$> resText) + Nothing -> do + when (is _Nothing route) $ + $(Yesod.logErrorS) "Servant" "Could not parse route even though servant responded successfully" + + Yesod.sendWaiResponse res + where + status = W.responseStatus res + resText = toText <$> getResBS + where + toText bs = case Text.decodeUtf8' bs of + Right t -> t + Left _ -> Text.decodeUtf8 $ Base64.encode bs + + (_, _, resStream) = W.responseToStream res + getResBS = resStream $ \runStream -> do + resVar <- newTVarIO Builder.empty + runStream (\chunk -> atomically $ modifyTVar' resVar (<> chunk)) (return ()) + toStrict . Builder.toLazyByteString <$> readTVarIO resVar + + yesodError :: Maybe (Text -> Yesod.ErrorResponse) + yesodError + | status == notFound404 + = Just $ const Yesod.NotFound + | status == internalServerError500 + = Just Yesod.InternalError + | status == badRequest400 + = Just $ Yesod.InvalidArgs . pure + | status == unauthorized401 + = Just $ const Yesod.NotAuthenticated + | status == forbidden403 + = Just Yesod.PermissionDenied + | status == methodNotAllowed405 + = Just . const . Yesod.BadMethod $ W.requestMethod req + | otherwise = Nothing + + fmap toTypedContent . withUnliftIO $ \UnliftIO{..} -> + (yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy' proxy)) ctx server') req $ unliftIO . sendResponse + +servantApiLink :: forall p1 p2 proxy endpoint. + ( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint), HasRoute (ServantApiUnproxy' proxy), HasLink endpoint, Typeable endpoint ) + => p1 proxy + -> p2 endpoint + -> MkLink endpoint (Route (ServantApi proxy)) +servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @(ServantApiUnproxy' proxy) . renderServantRoute) (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint) + where + guardEndpoint :: Maybe (Route (ServantApi proxy)) -> Maybe (Route (ServantApi proxy)) + guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _)) + | Just Refl <- eqT @endpoint @endpoint' = x + guardEndpoint _ = Nothing + + +class HasServantHandlerContext site where + data ServantHandlerContextFor site :: Type + getSCtxSite :: ServantHandlerContextFor site -> site + getSCtxRequest :: ServantHandlerContextFor site -> Request + +newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: ServantHandlerContextFor site -> Handler a } + deriving (Generic, Typeable) + deriving (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO, MonadBaseControl IO, MonadError ServerError) via (ReaderT (ServantHandlerContextFor site) Handler) + +instance MonadUnliftIO (ServantHandlerFor site) where + withRunInIO cont + = ServantHandlerFor $ \app -> withRunInIO $ \unliftHandler -> cont (unliftHandler . flip unServantHandlerFor app) + +getServantContext :: (site ~ site', MonadServantHandler site m) => m (ServantHandlerContextFor site') +getServantContext = liftServantHandler $ ServantHandlerFor return + +getsServantContext :: (site ~ site', MonadServantHandler site m) => (ServantHandlerContextFor site' -> a) -> m a +getsServantContext = liftServantHandler . ServantHandlerFor . (return .) + +getYesodApproot :: (Yesod site, MonadSite site m, MonadRequest m) => m Text +getYesodApproot = Yesod.getApprootText Yesod.approot <$> getSite <*> getRequest + +renderRouteAbsolute :: (Yesod site, MonadSite site m, MonadRequest m) => Route site -> m URI +renderRouteAbsolute (renderRoute -> (ps, qs)) = addRoute . unpack <$> getYesodApproot + where addRoute root = case parseURI root of + Just root' -> root' & uriPathLens . packed %~ addPath + & uriQueryLens . packed %~ addQuery + Nothing -> error "Could not parse approot as URI" + addPath p = p <> "/" <> Text.intercalate "/" ps + addQuery q | null qs = q + addQuery "" = "?" <> Text.intercalate "&" (map (\(q, v) -> q <> "=" <> v) qs) + addQuery "?" = addQuery "" + addQuery q = q <> "&" <> tailEx (addQuery "") + +servantApiBaseUrl :: (Yesod site, MonadSite site m, MonadRequest m, MonadThrow m) => (Route (ServantApi proxy) -> Route site) -> m BaseUrl +servantApiBaseUrl = parseBaseUrl . ($ mempty). uriToString (const "") <=< renderRouteAbsolute . ($ ServantApiBaseRoute) + +class (MonadIO m, HasServantHandlerContext site) => MonadServantHandler site m | m -> site where + liftServantHandler :: forall a. ServantHandlerFor site a -> m a + +instance HasServantHandlerContext site => MonadServantHandler site (ServantHandlerFor site) where + liftServantHandler = id + +instance (MonadTrans t, MonadIO (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadServantHandler site (t (ServantHandlerFor site)) where + liftServantHandler = lift + +class MonadIO m => MonadHandler m where + liftHandler :: forall a. Handler a -> m a + +instance MonadHandler (ServantHandlerFor site) where + liftHandler = ServantHandlerFor . const + +instance (MonadTrans t, MonadIO (t (ServantHandlerFor site))) => MonadHandler (t (ServantHandlerFor site)) where + liftHandler = lift . ServantHandlerFor . const + +class Monad m => MonadSite site m | m -> site where + getSite :: m site + + getsSite :: (site -> a) -> m a + getsSite f = f <$> getSite + +instance HasServantHandlerContext site => MonadSite site (ServantHandlerFor site) where + getSite = liftServantHandler . ServantHandlerFor $ return . getSCtxSite + +instance MonadSite site (Reader site) where + getSite = ask + getsSite = asks + +instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, site ~ Yesod.HandlerSite m) => MonadSite site m where + getSite = Yesod.getYesod + getsSite = Yesod.getsYesod + +instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadSite site (t (ServantHandlerFor site)) where + getSite = lift getSite + getsSite = lift . getsSite + +class Monad m => MonadRequest m where + getRequest :: m Request + +instance HasServantHandlerContext site => MonadRequest (ServantHandlerFor site) where + getRequest = liftServantHandler . ServantHandlerFor $ return . getSCtxRequest + +instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, Monad m) => MonadRequest m where + getRequest = Yesod.waiRequest + +instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadRequest (t (ServantHandlerFor site)) where + getRequest = lift getRequest + + +type ServantDBFor site = ReaderT (Yesod.YesodPersistBackend site) (ServantHandlerFor site) + +class Yesod.YesodPersist site => ServantPersist site where + runDB :: forall a. ServantDBFor site a -> ServantHandlerFor site a + +defaultRunDB :: ( PersistConfig c + , ServantDBFor site a ~ PersistConfigBackend c (ServantHandlerFor site) a + , HasServantHandlerContext site + ) + => Getting c site c + -> Getting (PersistConfigPool c) site (PersistConfigPool c) + -> ServantDBFor site a -> ServantHandlerFor site a +defaultRunDB confL poolL f = do + app <- getSite + runPool (app ^. confL) f (app ^. poolL) + + +class ServantLog site where + servantLogLog :: (MonadIO m, ToLogStr msg) => site -> Loc -> LogSource -> LogLevel -> msg -> m () + +newtype ServantLogYesod site = ServantLogYesod { unServantLogYesod :: site } + +instance Yesod site => ServantLog (ServantLogYesod site) where + servantLogLog (ServantLogYesod app) a b c (toLogStr -> d) = liftIO $ do + logger <- Yesod.makeLogger app + Yesod.messageLoggerSource app logger a b c d + +instance (ServantLog site, HasServantHandlerContext site) => MonadLogger (ServantHandlerFor site) where + monadLoggerLog a b c d = do + app <- getSite + servantLogLog app a b c d + +instance (ServantLog site, HasServantHandlerContext site) => MonadLoggerIO (ServantHandlerFor site) where + askLoggerIO = servantLogLog <$> getSite + + +newtype PathPieceHttpApiData a = PathPieceHttpApiData { unPathPieceHttpApiData :: a } + deriving (Eq, Ord, Read, Show, Generic, Typeable, Data) + deriving newtype (PathPiece, ToParamSchema) +instance PathPiece a => FromHttpApiData (PathPieceHttpApiData a) where + parseUrlPiece = maybe (Left "Could not convert from HttpApiData via PathPiece") Right . fromPathPiece +instance PathPiece a => ToHttpApiData (PathPieceHttpApiData a) where + toUrlPiece = toPathPiece + + +mkYesodApi :: Name -> [ResourceTree String] -> DecsQ +mkYesodApi (nameBase -> masterN) ress = do + let toPiecesApi :: [Piece String] + -> ResourceTree String + -> MaybeT Q [([Piece String], TH.Type, [Text])] + toPiecesApi ps (ResourceLeaf Resource{..}) = do + Subsite{..} <- pure resourceDispatch + Just tn <- lift $ lookupTypeName subsiteType + TyConI (TySynD _ [] (ConT conN `AppT` apiT)) <- lift $ reify tn + guard $ conN == ''ServantApi + return $ pure (ps <> resourcePieces, ConT ''ServantApiUnproxy' `AppT` apiT, map pack resourceAttrs) + toPiecesApi ps (ResourceParent _ _ ps' cs) + = lift . fmap concat $ mapMaybeM (toPiecesApi (ps <> ps')) cs + apiRess <- concat <$> mapMaybeM (toPiecesApi []) ress + + let apiType + | Just apiRess' <- fromNullable $ map apiEndpoint apiRess + = ofoldr1 (\e acc -> conT ''(:<|>) `appT` e `appT` acc) apiRess' + | otherwise + = conT ''EmptyAPI + + apiEndpoint (pieces, apiT, attrs) = withAuth attrs $ + foldr (\p acc -> conT ''(:>) `appT` apiPiece p `appT` acc) (return apiT) pieces + + withAuth attrs typ = case authDNF of + Left t + -> fail $ "Invalid auth tag: " <> unpack t + Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthFree) `Set.member` dnfTerms + -> typ + Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthToken) `Set.member` dnfTerms + -> conT ''(:>) `appT` conT ''BearerAuth `appT` typ + Right _ + -> conT ''(:>) `appT` conT ''SessionAuth `appT` typ + where authDNF = parsePredDNF defaultAuthDNF attrs + + apiPiece (Static str) = litT $ strTyLit str + apiPiece (Dynamic str) = conT ''PathPieceHttpApiData `appT` either fail return (parseType str) + + sequence + [ tySynD (mkName $ masterN <> "Api") [] apiType + ] diff --git a/src/Yesod/Servant/HttpApiDataInjective.hs b/src/Yesod/Servant/HttpApiDataInjective.hs new file mode 100644 index 000000000..1cd6097c3 --- /dev/null +++ b/src/Yesod/Servant/HttpApiDataInjective.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Yesod.Servant.HttpApiDataInjective + ( ToHttpApiDataInjective(..) + ) where + +import ClassyPrelude hiding (Builder) +import Web.HttpApiData +import Network.HTTP.Types.URI (encodePathSegmentsRelative) + +import qualified Data.Text.Lazy as Lazy (Text) + +import Data.Binary.Builder (Builder) + +import Data.Void (Void) +import Data.Int (Int8, Int16) +import Data.Word (Word16) +import Numeric.Natural (Natural) +import Data.Fixed (Fixed) +import Data.UUID (UUID) +import Data.Time (ZonedTime, LocalTime, TimeOfDay, NominalDiffTime, DayOfWeek) +import Data.CaseInsensitive (CI) +import Data.CaseInsensitive.Instances () +import qualified Data.CaseInsensitive as CI +import Data.Version (Version) +import Data.Monoid (Any, All) + +import Data.CryptoID (CryptoID(..)) + + +class ToHttpApiData a => ToHttpApiDataInjective a where + toUrlPieceInjective :: a -> Text + toUrlPieceInjective = toUrlPiece + + toEncodedUrlPieceInjective :: a -> Builder + toEncodedUrlPieceInjective = encodePathSegmentsRelative . pure . toUrlPiece + + -- | Convert to HTTP header value. + toHeaderInjective :: a -> ByteString + toHeaderInjective = encodeUtf8 . toUrlPiece + + -- | Convert to query param value. + toQueryParamInjective :: a -> Text + toQueryParamInjective = toQueryParam + +instance ToHttpApiDataInjective () +instance ToHttpApiDataInjective Bool +instance ToHttpApiDataInjective Ordering +instance ToHttpApiDataInjective Void +instance ToHttpApiDataInjective Double +instance ToHttpApiDataInjective Float +instance ToHttpApiDataInjective Int +instance ToHttpApiDataInjective Int8 +instance ToHttpApiDataInjective Int16 +instance ToHttpApiDataInjective Int32 +instance ToHttpApiDataInjective Int64 +instance ToHttpApiDataInjective Integer +instance ToHttpApiDataInjective Natural +instance ToHttpApiDataInjective Word +instance ToHttpApiDataInjective Word8 +instance ToHttpApiDataInjective Word16 +instance ToHttpApiDataInjective Word32 +instance ToHttpApiDataInjective Word64 +instance ToHttpApiData (Fixed a) => ToHttpApiDataInjective (Fixed a) +instance ToHttpApiDataInjective Char +instance ToHttpApiDataInjective Text +instance ToHttpApiDataInjective Lazy.Text +instance ToHttpApiDataInjective String +instance ToHttpApiDataInjective str => ToHttpApiDataInjective (CI str) where + toUrlPieceInjective = toUrlPieceInjective . CI.foldedCase + toEncodedUrlPieceInjective = toEncodedUrlPieceInjective . CI.foldedCase + toHeaderInjective = toHeaderInjective . CI.foldedCase + toQueryParamInjective = toQueryParamInjective . CI.foldedCase +instance ToHttpApiDataInjective Version +instance ToHttpApiDataInjective All +instance ToHttpApiDataInjective Any +instance ToHttpApiDataInjective UTCTime +instance ToHttpApiDataInjective ZonedTime +instance ToHttpApiDataInjective LocalTime +instance ToHttpApiDataInjective TimeOfDay +instance ToHttpApiDataInjective NominalDiffTime +instance ToHttpApiDataInjective Day +instance ToHttpApiDataInjective DayOfWeek +instance ToHttpApiDataInjective UUID +instance ToHttpApiDataInjective a => ToHttpApiDataInjective (Maybe a) +instance ToHttpApiDataInjective a => ToHttpApiDataInjective (CryptoID ns a) where + toUrlPieceInjective = toUrlPieceInjective . ciphertext + toEncodedUrlPieceInjective = toEncodedUrlPieceInjective . ciphertext + toHeaderInjective = toHeaderInjective . ciphertext + toQueryParamInjective = toQueryParamInjective . ciphertext diff --git a/stack.yaml b/stack.yaml index 78ea92379..80e724356 100644 --- a/stack.yaml +++ b/stack.yaml @@ -102,6 +102,8 @@ extra-deps: - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 # - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 - hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 + - servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755 + - servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 - network-arbitrary-0.7.0.0@sha256:0cd381c80ae20c16048936edcdb018b1d9fbe2b6ac8c44e908df403a5c6d7cd5,2520 # - process-extras-0.7.4@sha256:4e79289131415796c181889c4a226ebab7fc3b0d27b164f65e1aad123ae9b9e3,1759 diff --git a/stack.yaml.lock b/stack.yaml.lock index bde27967e..e55d4209e 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -500,6 +500,20 @@ packages: sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea 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 + 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 + original: + hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 - completed: hackage: network-arbitrary-0.7.0.0@sha256:0cd381c80ae20c16048936edcdb018b1d9fbe2b6ac8c44e908df403a5c6d7cd5,2520 pantry-tree: diff --git a/test/Foundation/ServantSpec.hs b/test/Foundation/ServantSpec.hs new file mode 100644 index 000000000..57ae11006 --- /dev/null +++ b/test/Foundation/ServantSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Foundation.ServantSpec where + +import TestImport hiding ((:>)) + +import ModelSpec () +import Foundation.Servant.Types + +import Servant.API +import Servant.QuickCheck.Internal.HasGenRequest (HasGenRequest(..)) + +import Data.CryptoID.Class.ImplicitNamespace + +import Network.HTTP.Client (path) + + +instance (Arbitrary (CryptoID ciphertext plaintext), ToHttpApiData ciphertext, HasGenRequest sub) => HasGenRequest (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where + genRequest _ = (oldf, ) $ do + old' <- old + new' <- toUrlPiece <$> new + return $ \burl -> let r = old' burl in r { path = encodeUtf8 new' <> path r } + where (oldf, old) = genRequest $ Proxy @sub + new = arbitrary @(CryptoID ciphertext plaintext) + +instance HasGenRequest sub => HasGenRequest (CaptureBearerToken' mods :> sub) where + genRequest _ = genRequest $ Proxy @sub + +instance HasGenRequest sub => HasGenRequest (CaptureBearerRestriction' mods restr :> sub) where + genRequest _ = genRequest $ Proxy @sub + +instance HasGenRequest sub => HasGenRequest (ApiVersion major minor patch :> sub) where + genRequest _ = genRequest $ Proxy @sub + +spec :: Spec +spec = return () diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs index f44875286..7978f43fe 100644 --- a/test/FoundationSpec.hs +++ b/test/FoundationSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module FoundationSpec where import TestImport @@ -6,6 +8,16 @@ import ModelSpec () import Yesod.EmbeddedStatic +import Servant.QuickCheck.Internal.HasGenRequest (HasGenRequest(..)) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types.URI as URI + +import Yesod.Servant (HasRoute(..), ServantApi, ServantApiUnproxy') + +import Foundation.ServantSpec () +import ServantApi.ExternalApis.TypeSpec () + + instance Arbitrary (Route Auth) where arbitrary = oneof [ return CheckR @@ -24,6 +36,14 @@ instance Arbitrary (Route EmbeddedStatic) where params <- replicateM paramNum $ (,) <$> printableText' <*> printableText return $ embeddedResourceR path params +instance (HasRoute (ServantApiUnproxy' api), HasGenRequest (ServantApiUnproxy' api)) => Arbitrary (Route (ServantApi api)) where + arbitrary = do + genReq <- view _2 . genRequest $ Proxy @(ServantApiUnproxy' api) + let req = genReq $ BaseUrl Http "" 0 "" + p = filter (not . null) . URI.decodePathSegments $ HTTP.path req + qs = over (traverse . _2) (fromMaybe mempty) . URI.parseQueryText $ HTTP.queryString req + maybe (error $ "Could not parse generated servant route: " <> show (p, qs)) return $ parseServantRoute (p, qs) + instance Arbitrary WellKnownFileName where arbitrary = genericArbitrary diff --git a/test/Jose/Jwk/TestInstances.hs b/test/Jose/Jwk/TestInstances.hs new file mode 100644 index 000000000..358bf547e --- /dev/null +++ b/test/Jose/Jwk/TestInstances.hs @@ -0,0 +1,34 @@ +module Jose.Jwk.TestInstances + () where + +import TestImport + +import Crypto.Random +import Jose.Jwk +import Jose.Jwt + + +instance Arbitrary KeyUse where + arbitrary = genericArbitrary + +instance Arbitrary JwkSet where + arbitrary = fmap (JwkSet . concat) . listOf $ do + kId <- UTCKeyId <$> arbitrary + kUse <- arbitrary + oneof + [ withDRG' $ do + (kPub, kPriv) <- generateRsaKeyPair 2048 kId kUse Nothing + return [kPub, kPriv] + , withDRG' $ + pure <$> generateSymmetricKey 32 kId kUse Nothing + ] + where + withDRG' c = do + seed <- (,,,,) + <$> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + let chacha = drgNewTest seed + return . fst $ withDRG chacha c diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 10da379ed..4823b57a6 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -7,6 +7,8 @@ module Model.TypesSpec import TestImport import Settings +import Utils (guardOn) + import Data.Aeson (Value) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson @@ -45,6 +47,12 @@ import qualified Data.Text.Lazy as LT import Text.Blaze.Html.Renderer.Text (renderHtml) +import qualified Data.SemVer as SemVer +import qualified Data.SemVer.Constraint as SemVer (Constraint) +import qualified Data.SemVer.Constraint as SemVer.Constraint + +import qualified Data.HashSet as HashSet + instance Arbitrary Season where @@ -337,6 +345,42 @@ instance Arbitrary RoomReference where instance Arbitrary RoomReference' where arbitrary = genericArbitrary +instance Arbitrary ExternalApiConfig where + arbitrary = oneof + [ EApiGradelistFormat <$> ((fmap HashSet.fromList . scale (`div` 10) $ listOf1 (resize 3 arbitrary)) `suchThatMap` fromNullable) + ] + shrink = genericShrink + +instance Arbitrary SemVer.Version where + arbitrary = SemVer.version + <$> fmap getNonNegative arbitrary + <*> fmap getNonNegative arbitrary + <*> fmap getNonNegative arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary SemVer.Identifier where + arbitrary = -- oneof + -- [ SemVer.numeric . getNonNegative <$> arbitrary -- Numeric does not roundtrip + {- , -} fmap (\s -> fromMaybe (error $ "Generated invalid SemVer.Identifier: " <> s) . SemVer.textual $ pack s) . listOf1 . elements $ ['A'..'Z'] <> ['a'..'z'] {- <> ['0'..'9'] -} <> ['-'] + -- ] + +deriving instance Generic SemVer.Constraint + +instance Arbitrary SemVer.Constraint where + -- Syntax has no brackets; so be very careful about nesting + arbitrary = sized $ \n -> oneof $ catMaybes + [ pure unitary + , guardOn (n > 1) conj + , guardOn (n > 1) disj + ] + where unitary = oneof + [ pure SemVer.Constraint.CAny + , elements [SemVer.Constraint.CLt, SemVer.Constraint.CLtEq, SemVer.Constraint.CGt, SemVer.Constraint.CGtEq, SemVer.Constraint.CEq] <*> arbitrary + ] + conj = SemVer.Constraint.CAnd <$> unitary <*> sized (\n -> oneof $ catMaybes [pure unitary, guardOn (n > 1) $ scale (`div` 2) conj]) + disj = SemVer.Constraint.COr <$> unitary <*> scale (`div` 2) arbitrary + instance Arbitrary UploadNonce where arbitrary = pure $ unsafePerformIO newUploadNonce @@ -347,6 +391,11 @@ instance Arbitrary SchoolAuthorshipStatementMode where instance Arbitrary SheetAuthorshipStatementMode where arbitrary = genericArbitrary +instance Arbitrary WorkflowWorkflowListType where + arbitrary = genericArbitrary +instance CoArbitrary WorkflowWorkflowListType +instance Function WorkflowWorkflowListType + spec :: Spec spec = do @@ -453,6 +502,10 @@ spec = do [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ] lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)) [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ] + lawsCheckHspec (Proxy @SemVer.Version) + [ eqLaws, ordLaws, showLaws, hashableLaws, httpApiDataLaws ] + lawsCheckHspec (Proxy @SemVer.Constraint) + [ eqLaws, showLaws, httpApiDataLaws ] lawsCheckHspec (Proxy @UploadNonce) [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws ] lawsCheckHspec (Proxy @SchoolAuthorshipStatementMode) diff --git a/test/Servant/Client/Core/BaseUrl/TestInstances.hs b/test/Servant/Client/Core/BaseUrl/TestInstances.hs new file mode 100644 index 000000000..86dbe9453 --- /dev/null +++ b/test/Servant/Client/Core/BaseUrl/TestInstances.hs @@ -0,0 +1,20 @@ +module Servant.Client.Core.BaseUrl.TestInstances + () where + +import TestImport + +import Network.URI +import Network.URI.Arbitrary () +import Servant.Client.Core.BaseUrl + +import Control.Lens.Extras + + +instance Arbitrary BaseUrl where + arbitrary = (`suchThatMap` toBaseUrl) $ do + uri <- scale (min 10) arbitrary `suchThat` (is _Just . uriAuthority) + uriScheme <- oneof $ map (return . (<> ":")) [ "http", "https" ] + let uriAuthority'' = uriAuthority uri <&> \uriAuthority' -> uriAuthority'{ uriUserInfo = "" } + return (uri, uriScheme, uriAuthority'') + where + toBaseUrl (uri, uriScheme, uriAuthority'') = either (const Nothing) Just . parseBaseUrl . ($ mempty) $ uriToString (const mempty) uri{ uriScheme, uriAuthority = uriAuthority'', uriQuery = "", uriFragment = "" } diff --git a/test/ServantApi/ExternalApis/TypeSpec.hs b/test/ServantApi/ExternalApis/TypeSpec.hs new file mode 100644 index 000000000..312aa6cad --- /dev/null +++ b/test/ServantApi/ExternalApis/TypeSpec.hs @@ -0,0 +1,19 @@ +module ServantApi.ExternalApis.TypeSpec where + +import TestImport +import TestInstances () +import Model.TypesSpec () + +import ServantApi.ExternalApis.Type + + +instance Arbitrary ExternalApiCreationRequest where + arbitrary = ExternalApiCreationRequest + <$> scale (`div` 2) arbitrary + <*> scale (`div` 2) arbitrary + <*> scale (`div` 2) arbitrary + shrink = genericShrink + + +spec :: Spec +spec = return () diff --git a/test/ServantApi/ExternalApisSpec.hs b/test/ServantApi/ExternalApisSpec.hs new file mode 100644 index 000000000..2fba5b343 --- /dev/null +++ b/test/ServantApi/ExternalApisSpec.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -Wno-error=unused-local-binds #-} + +module ServantApi.ExternalApisSpec where + +import TestImport +import ServantApi.ExternalApis.Type +import ServantApi.ExternalApis.TypeSpec () + +import Servant.Client.Core (RequestF(..)) +import Servant.Client.Generic + +import Utils.Tokens +import Data.Time.Clock (nominalDay) + +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap + +import qualified Data.Sequence as Seq + +import Control.Monad.Reader.Class (MonadReader(local)) +import Utils (CustomHeader(..), waiCustomHeader) + + +spec :: Spec +spec = withApp . describe "ExternalApis" $ do + it "Supports dryRun" $ do + adminId <- runDB $ do + Entity adminId _ <- insertEntity $ fakeUser id + ifi <- insert $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional Nothing True SchoolAuthorshipStatementModeRequired Nothing False + insert_ $ UserFunction adminId ifi SchoolAdmin + return adminId + + accessToken <- runHandler $ encodeBearer =<< bearerToken (HashSet.singleton $ Right adminId) Nothing HashMap.empty Nothing Nothing Nothing + + let + insertExternalApi = void $ externalApisCreateR accessToken =<< liftIO (generate $ resize 10 arbitrary) + where ExternalApis{..} = genericClient + withDryRun :: ServantExampleEnv -> ServantExampleEnv + withDryRun seEnv = seEnv + { yseMakeClientRequest = \burl req -> yseMakeClientRequest seEnv burl req{ requestHeaders = requestHeaders req Seq.:|> waiCustomHeader HeaderDryRun True } + } + externalApiCount = runDB $ count @_ @_ @ExternalApi [] + + runServantExample ExternalApisR insertExternalApi + liftIO . (`shouldBe` 1) =<< externalApiCount + + runServantExample ExternalApisR $ local withDryRun insertExternalApi + liftIO . (`shouldBe` 1) =<< externalApiCount diff --git a/test/ServantApiSpec.hs b/test/ServantApiSpec.hs new file mode 100644 index 000000000..001e9a7e7 --- /dev/null +++ b/test/ServantApiSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module ServantApiSpec where + +import TestImport +import ServantApi + +import Servant.API +import Servant.API.TypeLevel (MapSub, AppendList) +import Foundation.Servant.Types (ApiVersion) + +import GHC.TypeLits +import Data.Kind (Constraint) + + +type family Unversioned api where + Unversioned (ApiVersion _ _ _ :> _) = '[] + Unversioned (sup :> sub) = MapSub sup (Unversioned sub) + Unversioned (a :<|> b) = AppendList (Unversioned a) (Unversioned b) + Unversioned (Verb method statusCode contentTypes a) = '[Verb method statusCode contentTypes a] + Unversioned (NoContentVerb method) = '[NoContentVerb method] + +type family UnversionedError xs :: ErrorMessage where + UnversionedError (x ': '[]) = 'Text "Unversioned API endpoint: " ':$$: ('Text " " ':<>: 'ShowType x) + UnversionedError (x ': xs) = UnversionedError (x ': '[]) ':$$: UnversionedError xs + +type family IsEmpty xs :: Constraint where + IsEmpty '[] = () + IsEmpty xs = TypeError ('Text "All API endpoints must be versioned." ':$$: UnversionedError xs) + +spec :: Spec +spec = describe "Servant endpoints" $ it "are all versioned" versioned + where + versioned :: IsEmpty (Unversioned UniWorXApi) => Bool + versioned = True diff --git a/test/TestImport.hs b/test/TestImport.hs index be362d41d..ed01b32da 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module TestImport ( module TestImport , module X @@ -44,6 +46,34 @@ import Jobs (handleJobs) import Numeric.Natural as X import Network.URI.Arbitrary as X () +import qualified Network.Wai as Wai +import qualified Network.Wai.Test as Wai +import qualified Network.Wai.Test.Internal as Wai (ClientState) +import Network.HTTP.Types (Status(..), hContentType, hAccept) +import Network.HTTP.Types.Header (hHost) +import qualified Network.HTTP.Types as Wai + +import Control.Monad.Trans.Except (ExceptT) +import qualified Servant.Client.Core as Servant +import Servant.Client.Core.ClientError +import Servant.Client.Core.RunClient +import Control.Monad.Except (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) +import qualified Control.Monad.State.Class as State +import qualified Servant.Types.SourceT as S +import Servant.API (SourceIO) + +import Utils (throwExceptT) + +import Yesod.Servant (ServantApi, servantApiBaseUrl) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as LBS hiding (ByteString) +import qualified Data.Binary.Builder as B +import Network.HTTP.Media (renderHeader) +import Control.Monad.Fail + import Control.Lens as X hiding ((<.), elements) import Network.IP.Addr as X (IP) @@ -133,3 +163,105 @@ lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . where checkHspec (Laws className properties) = describe className $ forM_ properties $ \(name, prop) -> it name $ property prop + + +newtype ServantExample a = ServantExample + { unServantExample :: ReaderT ServantExampleEnv (ExceptT ClientError Wai.Session) a + } deriving stock (Generic, Typeable) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ServantExampleEnv, MonadError ClientError, MonadThrow, MonadCatch, MonadState Wai.ClientState) + +data ServantExampleEnv = ServantExampleEnv + { yseBaseUrl :: BaseUrl + , yseMakeClientRequest :: BaseUrl -> Servant.Request -> IO Wai.Request + } deriving (Generic, Typeable) + +runServantExample :: (Route (ServantApi proxy) -> Route UniWorX) -> ServantExample a -> YesodExample UniWorX a +runServantExample apiR (ServantExample act) = do + yseBaseUrl <- runHandler $ servantApiBaseUrl apiR + let yseMakeClientRequest burl Servant.Request{..} = do + ((body, bodyLength), contentTypeHdr) <- case requestBody of + Nothing -> return ((return BS.empty, Wai.KnownLength 0), Nothing) + Just (body', typ) -> let (mkBody, bLength) = convertBody body' + in (, Just (hContentType, renderHeader typ)) . (, bLength) <$> mkBody + + return $ Wai.defaultRequest + { Wai.requestMethod = requestMethod + , Wai.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers + , Wai.requestHeaderHost = + let BaseUrl{..} = yseBaseUrl + in Just . encodeUtf8 . pack $ baseUrlHost <> bool (":" <> show baseUrlPort) mempty (baseUrlPort == 80) + , Wai.requestBody = body, Wai.requestBodyLength = bodyLength + , Wai.isSecure = isSecure + } + & flip Wai.setPath (encodeUtf8 (pack $ baseUrlPath burl) <> toStrict (B.toLazyByteString requestPath) <> Wai.renderQuery True (toList requestQueryString)) + where + headers = filter (\(h, _) -> h `notElem` [hAccept, hContentType, hHost]) $ toList requestHeaders + + acceptHdr + | null hs = Nothing + | otherwise = Just (hAccept, renderHeader hs) + where + hs = toList requestAccept + + convertBody :: Servant.RequestBody -> (IO (IO ByteString), Wai.RequestBodyLength) + convertBody bd = case bd of + Servant.RequestBodyLBS body' -> ( givesPopper . S.source . map fromStrict $ LBS.toChunks body' + , Wai.KnownLength . fromIntegral $ LBS.length body' + ) + Servant.RequestBodyBS body' -> ( return $ return body' + , Wai.KnownLength . fromIntegral $ BS.length body' + ) + Servant.RequestBodySource sourceIO -> ( givesPopper sourceIO + , Wai.ChunkedBody + ) + where + givesPopper :: SourceIO Lazy.ByteString -> IO (IO ByteString) + givesPopper sourceIO = S.unSourceT sourceIO $ \step0 -> do + ref <- newMVar step0 + return $ modifyMVar ref nextBs + + nextBs S.Stop = return (S.Stop, BS.empty) + nextBs (S.Error err) = fail err + nextBs (S.Skip s) = nextBs s + nextBs (S.Effect ms) = ms >>= nextBs + nextBs (S.Yield lbs s) = case LBS.toChunks lbs of + [] -> nextBs s + (x:xs) | BS.null x -> nextBs step' + | otherwise -> return (step', x) + where + step' = S.Yield (LBS.fromChunks xs) s + + isSecure = case baseUrlScheme burl of + Servant.Http -> False + Servant.Https -> True + YesodExampleData waiApp _ _ _ <- State.get + liftIO . flip Wai.runSession waiApp . throwExceptT $ runReaderT act ServantExampleEnv{..} + +instance RunClient ServantExample where + runRequestAcceptStatus acceptStatus req = do + ServantExampleEnv{..} <- ask + waiRequest <- liftIO $ yseMakeClientRequest yseBaseUrl req + waiResponse@Wai.SResponse{..} <- ServantExample . lift . lift $ Wai.request waiRequest + let Status{..} = simpleStatus + statusOk = case acceptStatus of + Nothing -> 200 <= statusCode && statusCode < 300 + Just good -> simpleStatus `elem` good + response = (waiResponseToResponse waiResponse) { Servant.responseHttpVersion = Wai.httpVersion waiRequest } + unless statusOk $ + throwError $ mkFailureResponse yseBaseUrl req response + return response + where + mkFailureResponse :: BaseUrl -> Servant.Request -> Servant.ResponseF Lazy.ByteString -> ClientError + mkFailureResponse burl request' = + FailureResponse (bimap (const ()) f request') + where + f b = (burl, LBS.toStrict $ B.toLazyByteString b) + + waiResponseToResponse :: Wai.SResponse -> Servant.Response + waiResponseToResponse Wai.SResponse{..} = Servant.Response + { responseStatusCode = simpleStatus + , responseBody = simpleBody + , responseHeaders = fromList simpleHeaders + , responseHttpVersion = error "WAI Response does not carry http version information" + } + throwClientError = throwError diff --git a/test/TestInstances.hs b/test/TestInstances.hs index 431110d65..10fc19d75 100644 --- a/test/TestInstances.hs +++ b/test/TestInstances.hs @@ -5,4 +5,6 @@ module TestInstances import Text.Blaze.TestInstances as TestInstances () import Database.Persist.Sql.Types.TestInstances as TestInstances () import Data.NonNull.TestInstances as TestInstances () +import Jose.Jwk.TestInstances as TestInstances () +import Servant.Client.Core.BaseUrl.TestInstances as TestInstances () import Crypto.Hash.TestInstances as TestInstances () diff --git a/testdata/workflows b/testdata/workflows index 56b708bb4..d567d2957 160000 --- a/testdata/workflows +++ b/testdata/workflows @@ -1 +1 @@ -Subproject commit 56b708bb4741317ab9b9544b8e7834ca25a6a0c1 +Subproject commit d567d2957cd2a53fb79d2b60e650236509ffe726