Merge branch 'master' into merge-requests/37
This commit is contained in:
Gregor Kleen
commit
330a2fd974
4
.gitignore
vendored
4
.gitignore
vendored
@ -44,4 +44,6 @@ tunnel.log
|
|||||||
/sessions
|
/sessions
|
||||||
/changelog.json
|
/changelog.json
|
||||||
/.current-version
|
/.current-version
|
||||||
/.current-changelog.md
|
/.current-changelog.md
|
||||||
|
**/.direnv
|
||||||
|
.develop.env
|
||||||
@ -7,14 +7,6 @@ workflow:
|
|||||||
default:
|
default:
|
||||||
image:
|
image:
|
||||||
name: fpco/stack-build:lts-16.31
|
name: fpco/stack-build:lts-16.31
|
||||||
cache: &global_cache
|
|
||||||
key: default
|
|
||||||
paths:
|
|
||||||
- .npm
|
|
||||||
- node_modules
|
|
||||||
- .stack
|
|
||||||
- .stack-work
|
|
||||||
- .well-known-cache
|
|
||||||
|
|
||||||
variables:
|
variables:
|
||||||
STACK_ROOT: "${CI_PROJECT_DIR}/.stack"
|
STACK_ROOT: "${CI_PROJECT_DIR}/.stack"
|
||||||
@ -43,6 +35,13 @@ stages:
|
|||||||
# - deploy
|
# - deploy
|
||||||
|
|
||||||
npm install:
|
npm install:
|
||||||
|
cache:
|
||||||
|
- &npm-cache
|
||||||
|
key: default-npm
|
||||||
|
paths:
|
||||||
|
- .npm
|
||||||
|
- node_modules
|
||||||
|
|
||||||
stage: setup
|
stage: setup
|
||||||
script:
|
script:
|
||||||
- ./.npmrc.gup
|
- ./.npmrc.gup
|
||||||
@ -69,6 +68,12 @@ npm install:
|
|||||||
interruptible: true
|
interruptible: true
|
||||||
|
|
||||||
frontend:build:
|
frontend:build:
|
||||||
|
cache:
|
||||||
|
- &frontend-cache
|
||||||
|
key: default-frontend
|
||||||
|
paths:
|
||||||
|
- .well-known-cache
|
||||||
|
|
||||||
stage: frontend:build
|
stage: frontend:build
|
||||||
script:
|
script:
|
||||||
- npm run frontend:build
|
- npm run frontend:build
|
||||||
@ -98,6 +103,13 @@ frontend:lint:
|
|||||||
interruptible: true
|
interruptible: true
|
||||||
|
|
||||||
yesod:build:dev:
|
yesod:build:dev:
|
||||||
|
cache:
|
||||||
|
- &stack-dev-cache
|
||||||
|
key: default-stack-dev
|
||||||
|
paths:
|
||||||
|
- .stack
|
||||||
|
- .stack-work
|
||||||
|
|
||||||
stage: yesod:build
|
stage: yesod:build
|
||||||
script:
|
script:
|
||||||
- stack build --test --copy-bins --local-bin-path $(pwd)/bin --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic --no-strip --no-run-tests
|
- stack build --test --copy-bins --local-bin-path $(pwd)/bin --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic --no-strip --no-run-tests
|
||||||
@ -124,7 +136,7 @@ yesod:build:dev:
|
|||||||
paths:
|
paths:
|
||||||
- bin/
|
- bin/
|
||||||
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
||||||
expire_in: "1 week"
|
expire_in: "1 day"
|
||||||
|
|
||||||
rules:
|
rules:
|
||||||
- if: $CI_COMMIT_REF_NAME =~ /(^v[0-9].*)|((^|\/)profile($|\/))/
|
- if: $CI_COMMIT_REF_NAME =~ /(^v[0-9].*)|((^|\/)profile($|\/))/
|
||||||
@ -136,6 +148,13 @@ yesod:build:dev:
|
|||||||
interruptible: true
|
interruptible: true
|
||||||
|
|
||||||
yesod:build:
|
yesod:build:
|
||||||
|
cache:
|
||||||
|
- &stack-cache
|
||||||
|
key: default-stack
|
||||||
|
paths:
|
||||||
|
- .stack
|
||||||
|
- .stack-work
|
||||||
|
|
||||||
stage: yesod:build
|
stage: yesod:build
|
||||||
script:
|
script:
|
||||||
- stack build --test --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --no-strip --no-run-tests
|
- stack build --test --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --no-strip --no-run-tests
|
||||||
@ -151,7 +170,7 @@ yesod:build:
|
|||||||
paths:
|
paths:
|
||||||
- bin/
|
- bin/
|
||||||
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
||||||
expire_in: "1 week"
|
expire_in: "1 day"
|
||||||
|
|
||||||
rules:
|
rules:
|
||||||
- if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
|
- if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
|
||||||
@ -165,8 +184,11 @@ yesod:build:
|
|||||||
|
|
||||||
yesod:build:profile:
|
yesod:build:profile:
|
||||||
cache:
|
cache:
|
||||||
<<: *global_cache
|
- &stack-profile-cache
|
||||||
policy: pull
|
key: default-stack-profile
|
||||||
|
paths:
|
||||||
|
- .stack
|
||||||
|
- .stack-work
|
||||||
|
|
||||||
stage: yesod:build
|
stage: yesod:build
|
||||||
script:
|
script:
|
||||||
@ -181,7 +203,7 @@ yesod:build:profile:
|
|||||||
paths:
|
paths:
|
||||||
- bin/
|
- bin/
|
||||||
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
||||||
expire_in: "1 week"
|
expire_in: "1 day"
|
||||||
|
|
||||||
rules:
|
rules:
|
||||||
- if: $CI_COMMIT_REF_NAME =~ /(^|\/)profile($|\/)/
|
- if: $CI_COMMIT_REF_NAME =~ /(^|\/)profile($|\/)/
|
||||||
@ -195,7 +217,6 @@ yesod:build:profile:
|
|||||||
|
|
||||||
yesod:test:yesod:
|
yesod:test:yesod:
|
||||||
stage: test
|
stage: test
|
||||||
cache: {}
|
|
||||||
|
|
||||||
services: &test-services
|
services: &test-services
|
||||||
- name: postgres:10.10
|
- name: postgres:10.10
|
||||||
@ -224,7 +245,6 @@ yesod:test:yesod:
|
|||||||
|
|
||||||
yesod:test:yesod:dev:
|
yesod:test:yesod:dev:
|
||||||
stage: test
|
stage: test
|
||||||
cache: {}
|
|
||||||
|
|
||||||
services: *test-services
|
services: *test-services
|
||||||
|
|
||||||
@ -271,14 +291,13 @@ yesod:test:hlint:
|
|||||||
before_script: *haskell
|
before_script: *haskell
|
||||||
script:
|
script:
|
||||||
- stack install hlint
|
- stack install hlint
|
||||||
- stack exec -- hlint --cc src > gl-code-quality-report.json
|
- stack exec -- hlint --cc src > gl-code-quality-report.json || jq . gl-code-quality-report.json
|
||||||
- jq . gl-code-quality-report.json
|
|
||||||
|
|
||||||
artifacts:
|
artifacts:
|
||||||
paths:
|
paths:
|
||||||
- gl-code-quality-report.json
|
- gl-code-quality-report.json
|
||||||
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
||||||
expire_in: "1 week"
|
expire_in: "1 day"
|
||||||
|
|
||||||
reports:
|
reports:
|
||||||
codequality: gl-code-quality-report.json
|
codequality: gl-code-quality-report.json
|
||||||
@ -307,14 +326,13 @@ yesod:test:hlint:dev:
|
|||||||
before_script: *haskell
|
before_script: *haskell
|
||||||
script:
|
script:
|
||||||
- stack install hlint
|
- stack install hlint
|
||||||
- stack exec -- hlint --cc src > gl-code-quality-report.json
|
- stack exec -- hlint --cc src > gl-code-quality-report.json || jq . gl-code-quality-report.json
|
||||||
- jq . gl-code-quality-report.json
|
|
||||||
|
|
||||||
artifacts:
|
artifacts:
|
||||||
paths:
|
paths:
|
||||||
- gl-code-quality-report.json
|
- gl-code-quality-report.json
|
||||||
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
||||||
expire_in: "1 week"
|
expire_in: "1 day"
|
||||||
|
|
||||||
reports:
|
reports:
|
||||||
codequality: gl-code-quality-report.json
|
codequality: gl-code-quality-report.json
|
||||||
@ -323,9 +341,6 @@ yesod:test:hlint:dev:
|
|||||||
interruptible: true
|
interruptible: true
|
||||||
|
|
||||||
frontend:test:
|
frontend:test:
|
||||||
cache:
|
|
||||||
<<: *global_cache
|
|
||||||
policy: pull
|
|
||||||
stage: test
|
stage: test
|
||||||
script:
|
script:
|
||||||
- npm run frontend:test
|
- npm run frontend:test
|
||||||
@ -346,7 +361,6 @@ frontend:test:
|
|||||||
interruptible: true
|
interruptible: true
|
||||||
|
|
||||||
parse-changelog:
|
parse-changelog:
|
||||||
cache: {}
|
|
||||||
stage: prepare release
|
stage: prepare release
|
||||||
needs:
|
needs:
|
||||||
- job: npm install
|
- job: npm install
|
||||||
@ -375,7 +389,6 @@ parse-changelog:
|
|||||||
interruptible: true
|
interruptible: true
|
||||||
|
|
||||||
upload:
|
upload:
|
||||||
cache: {}
|
|
||||||
variables:
|
variables:
|
||||||
GIT_STRATEGY: none
|
GIT_STRATEGY: none
|
||||||
stage: upload packages
|
stage: upload packages
|
||||||
@ -413,7 +426,6 @@ upload:
|
|||||||
curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworx-wflint ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx-wflint
|
curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworx-wflint ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx-wflint
|
||||||
|
|
||||||
release:
|
release:
|
||||||
cache: {}
|
|
||||||
variables:
|
variables:
|
||||||
GIT_STRATEGY: none
|
GIT_STRATEGY: none
|
||||||
stage: release
|
stage: release
|
||||||
|
|||||||
25
CHANGELOG.md
25
CHANGELOG.md
@ -2,6 +2,31 @@
|
|||||||
|
|
||||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||||
|
|
||||||
|
## [25.10.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.4...v25.10.5) (2021-05-07)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* update imprint & add instructions for help ([eec9a39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/eec9a3974fc4cde5cc70ab650d018667ce044a92))
|
||||||
|
|
||||||
|
## [25.10.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.3...v25.10.4) (2021-05-06)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **workflow-workflow-list:** restore default sorting ([454a917](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/454a91702bdbbed7e473ef94a603bcea2e716406))
|
||||||
|
|
||||||
|
## [25.10.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.2...v25.10.3) (2021-05-05)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* restore workflowWorkflowList columns ([e55c6d7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e55c6d795fd724bdb732e22d13c96d6b67ea7da1))
|
||||||
|
|
||||||
|
## [25.10.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.1...v25.10.2) (2021-05-04)
|
||||||
|
|
||||||
|
## [25.10.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.0...v25.10.1) (2021-05-04)
|
||||||
|
|
||||||
## [25.10.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.3...v25.10.0) (2021-04-15)
|
## [25.10.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.3...v25.10.0) (2021-04-15)
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
44
flake.lock
Normal file
44
flake.lock
Normal file
@ -0,0 +1,44 @@
|
|||||||
|
{
|
||||||
|
"nodes": {
|
||||||
|
"flake-utils": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1619345332,
|
||||||
|
"narHash": "sha256-qHnQkEp1uklKTpx3MvKtY6xzgcqXDsz5nLilbbuL+3A=",
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"rev": "2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "numtide",
|
||||||
|
"ref": "master",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"nixpkgs": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1620323686,
|
||||||
|
"narHash": "sha256-+gfcE3YTGl+Osc8HzOUXSFO8/0PAK4J8ZxCXZ4hjXHI=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "dfacb8329b2236688b9a1e705116203a213b283a",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "NixOS",
|
||||||
|
"ref": "master",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-utils": "flake-utils",
|
||||||
|
"nixpkgs": "nixpkgs"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": "root",
|
||||||
|
"version": 7
|
||||||
|
}
|
||||||
27
flake.nix
Normal file
27
flake.nix
Normal file
@ -0,0 +1,27 @@
|
|||||||
|
{
|
||||||
|
inputs = {
|
||||||
|
nixpkgs = {
|
||||||
|
type = "github";
|
||||||
|
owner = "NixOS";
|
||||||
|
repo = "nixpkgs";
|
||||||
|
ref = "master";
|
||||||
|
};
|
||||||
|
flake-utils = {
|
||||||
|
type = "github";
|
||||||
|
owner = "numtide";
|
||||||
|
repo = "flake-utils";
|
||||||
|
ref = "master";
|
||||||
|
};
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs = { nixpkgs, flake-utils, ... }: flake-utils.lib.eachDefaultSystem
|
||||||
|
(system:
|
||||||
|
let pkgs = import nixpkgs {
|
||||||
|
inherit system;
|
||||||
|
config.allowUnfree = true;
|
||||||
|
};
|
||||||
|
in {
|
||||||
|
devShell = import ./shell.nix { inherit pkgs; };
|
||||||
|
}
|
||||||
|
);
|
||||||
|
}
|
||||||
18
nixpkgs.nix
18
nixpkgs.nix
@ -1,10 +1,8 @@
|
|||||||
{ nixpkgs ? import <nixpkgs>
|
import (
|
||||||
}:
|
let
|
||||||
|
lock = builtins.fromJSON (builtins.readFile ./flake.lock);
|
||||||
import ((nixpkgs {}).fetchFromGitHub {
|
in fetchTarball {
|
||||||
owner = "NixOS";
|
url = "https://api.github.com/repos/NixOS/nixpkgs/tarball/${lock.nodes.nixpkgs.locked.rev}";
|
||||||
repo = "nixpkgs";
|
sha256 = lock.nodes.nixpkgs.locked.narHash;
|
||||||
rev = "a7a1447e5d40a9ad90983d33e151f5474eddeed9";
|
}
|
||||||
sha256 = "1zb8wgsq9grrsdcz81y08h45rj8i5r8ckjhg2cv1cqmam4dczcrf";
|
)
|
||||||
fetchSubmodules = true;
|
|
||||||
})
|
|
||||||
|
|||||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "25.10.0",
|
"version": "25.10.5",
|
||||||
"lockfileVersion": 1,
|
"lockfileVersion": 1,
|
||||||
"requires": true,
|
"requires": true,
|
||||||
"dependencies": {
|
"dependencies": {
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "25.10.0",
|
"version": "25.10.5",
|
||||||
"description": "",
|
"description": "",
|
||||||
"keywords": [],
|
"keywords": [],
|
||||||
"author": "",
|
"author": "",
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: uniworx
|
name: uniworx
|
||||||
version: 25.10.0
|
version: 25.10.5
|
||||||
dependencies:
|
dependencies:
|
||||||
- base
|
- base
|
||||||
- yesod
|
- yesod
|
||||||
|
|||||||
230
shell.nix
230
shell.nix
@ -1,12 +1,8 @@
|
|||||||
{ nixpkgs ? import ./nixpkgs.nix {} }:
|
{ pkgs ? (import ./nixpkgs.nix).pkgs }:
|
||||||
|
|
||||||
let
|
let
|
||||||
inherit (nixpkgs {}) pkgs;
|
|
||||||
# haskellPackages = import ./stackage.nix { inherit nixpkgs; };
|
|
||||||
haskellPackages = pkgs.haskellPackages;
|
haskellPackages = pkgs.haskellPackages;
|
||||||
|
|
||||||
drv = haskellPackages.callPackage ./uniworx.nix {};
|
|
||||||
|
|
||||||
postgresSchema = pkgs.writeText "schema.sql" ''
|
postgresSchema = pkgs.writeText "schema.sql" ''
|
||||||
CREATE USER uniworx WITH SUPERUSER;
|
CREATE USER uniworx WITH SUPERUSER;
|
||||||
CREATE DATABASE uniworx_test;
|
CREATE DATABASE uniworx_test;
|
||||||
@ -19,129 +15,167 @@ let
|
|||||||
local all all trust
|
local all all trust
|
||||||
'';
|
'';
|
||||||
|
|
||||||
override = oldAttrs: {
|
develop = pkgs.writeScriptBin "develop" ''
|
||||||
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
|
#!${pkgs.zsh}/bin/zsh
|
||||||
shellHook = ''
|
|
||||||
export PROMPT_INFO="${oldAttrs.name}"
|
|
||||||
|
|
||||||
export EDITOR=emacsclient
|
cleanup() {
|
||||||
|
set +e -x
|
||||||
|
type cleanup_postgres &>/dev/null && cleanup_postgres
|
||||||
|
type cleanup_widget_memcached &>/dev/null && cleanup_widget_memcached
|
||||||
|
type cleanup_session_memcached &>/dev/null && cleanup_session_memcached
|
||||||
|
type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached
|
||||||
|
type cleanup_minio &>/dev/null && cleanup_minio
|
||||||
|
|
||||||
cleanup() {
|
[ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env"
|
||||||
set +e -x
|
set +x
|
||||||
type cleanup_postgres &>/dev/null && cleanup_postgres
|
}
|
||||||
type cleanup_widget_memcached &>/dev/null && cleanup_widget_memcached
|
|
||||||
type cleanup_session_memcached &>/dev/null && cleanup_session_memcached
|
trap cleanup EXIT
|
||||||
type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached
|
|
||||||
type cleanup_minio &>/dev/null && cleanup_minio
|
basePath=$(pwd)
|
||||||
set +x
|
|
||||||
|
echo "" > ''${basePath}/.develop.env
|
||||||
|
|
||||||
|
export PORT_OFFSET=$(((16#$(whoami | sha256sum | head -c 16)) % 1000))
|
||||||
|
|
||||||
|
if [[ -z "$PGHOST" ]]; then
|
||||||
|
set -xe
|
||||||
|
|
||||||
|
pgDir=$(mktemp -d --tmpdir=''${XDG_RUNTIME_DIR} postgresql.XXXXXX)
|
||||||
|
pgSockDir=$(mktemp -d --tmpdir=''${XDG_RUNTIME_DIR} postgresql.sock.XXXXXX)
|
||||||
|
pgLogFile=$(mktemp --tmpdir=''${XDG_RUNTIME_DIR} postgresql.XXXXXX.log)
|
||||||
|
initdb --no-locale -D ''${pgDir}
|
||||||
|
pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms"
|
||||||
|
psql -h ''${pgSockDir} -f ${postgresSchema} postgres
|
||||||
|
printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}
|
||||||
|
|
||||||
|
export PGHOST=''${pgSockDir}
|
||||||
|
export PGLOG=''${pgLogFile}
|
||||||
|
|
||||||
|
cleanup_postgres() {
|
||||||
|
set +e -x
|
||||||
|
pg_ctl stop -D ''${pgDir}
|
||||||
|
rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
|
||||||
|
set +x
|
||||||
}
|
}
|
||||||
|
|
||||||
trap cleanup EXIT
|
set +xe
|
||||||
|
fi
|
||||||
|
|
||||||
if [[ -z "$PGHOST" ]]; then
|
if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then
|
||||||
set -xe
|
set -xe
|
||||||
|
|
||||||
pgDir=$(mktemp -d)
|
memcached -l localhost -p $(($PORT_OFFSET + 11211)) &>/dev/null &
|
||||||
pgSockDir=$(mktemp -d)
|
widget_memcached_pid=$!
|
||||||
pgLogFile=$(mktemp)
|
|
||||||
initdb --no-locale -D ''${pgDir}
|
|
||||||
pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms"
|
|
||||||
export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile}
|
|
||||||
psql -f ${postgresSchema} postgres
|
|
||||||
printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}
|
|
||||||
|
|
||||||
cleanup_postgres() {
|
export WIDGET_MEMCACHED_HOST=localhost
|
||||||
set +e -x
|
export WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211))
|
||||||
pg_ctl stop -D ''${pgDir}
|
|
||||||
rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
|
|
||||||
set +x
|
|
||||||
}
|
|
||||||
|
|
||||||
set +xe
|
cleanup_widget_memcached() {
|
||||||
fi
|
[[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid
|
||||||
|
}
|
||||||
|
|
||||||
if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then
|
set +xe
|
||||||
set -xe
|
fi
|
||||||
|
|
||||||
memcached -l localhost -p 11211 &>/dev/null &
|
if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then
|
||||||
widget_memcached_pid=$?
|
set -xe
|
||||||
|
|
||||||
cleanup_widget_memcached() {
|
memcached -l localhost -p $(($PORT_OFFSET + 11212)) &>/dev/null &
|
||||||
[[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid
|
session_memcached_pid=$!
|
||||||
}
|
|
||||||
|
|
||||||
export WIDGET_MEMCACHED_HOST=localhost WIDGET_MEMCACHED_PORT=11211
|
export SESSION_MEMCACHED_HOST=localhost
|
||||||
|
export SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212))
|
||||||
|
|
||||||
set +xe
|
cleanup_session_memcached() {
|
||||||
fi
|
[[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid
|
||||||
|
}
|
||||||
|
|
||||||
if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then
|
set +xe
|
||||||
set -xe
|
fi
|
||||||
|
|
||||||
memcached -l localhost -p 11212 &>/dev/null &
|
if [[ -z "$MEMCACHED_HOST" ]]; then
|
||||||
session_memcached_pid=$?
|
set -xe
|
||||||
|
|
||||||
cleanup_session_memcached() {
|
memcached -l localhost -p $(($PORT_OFFSET + 11213)) &>/dev/null &
|
||||||
[[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid
|
memcached_pid=$!
|
||||||
}
|
|
||||||
|
|
||||||
export SESSION_MEMCACHED_HOST=localhost SESSION_MEMCACHED_PORT=11212
|
export MEMCACHED_HOST=localhost
|
||||||
|
export MEMCACHED_PORT=$(($PORT_OFFSET + 11212))
|
||||||
|
|
||||||
set +xe
|
cleanup_session_memcached() {
|
||||||
fi
|
[[ -n "$memcached_pid" ]] && kill $memcached_pid
|
||||||
|
}
|
||||||
|
|
||||||
if [[ -z "$MEMCACHED_HOST" ]]; then
|
set +xe
|
||||||
set -xe
|
fi
|
||||||
|
|
||||||
memcached -l localhost -p 11213 &>/dev/null &
|
if [[ -z "$UPLOAD_S3_HOST" ]]; then
|
||||||
memcached_pid=$?
|
set -xe
|
||||||
|
|
||||||
cleanup_session_memcached() {
|
cleanup_minio() {
|
||||||
[[ -n "$memcached_pid" ]] && kill $memcached_pid
|
[[ -n "$minio_pid" ]] && kill $minio_pid
|
||||||
}
|
[[ -n "''${MINIO_DIR}" ]] && rm -rvf ''${MINIO_DIR}
|
||||||
|
[[ -n "''${MINIO_LOGFILE}" ]] && rm -rvf ''${MINIO_LOGFILE}
|
||||||
|
}
|
||||||
|
|
||||||
export MEMCACHED_HOST=localhost MEMCACHED_PORT=11212
|
export MINIO_DIR=$(mktemp -d --tmpdir=''${XDG_RUNTIME_DIR} minio.XXXXXX)
|
||||||
|
export MINIO_LOGFILE=$(mktemp --tmpdir=''${XDG_RUNTIME_DIR} minio.XXXXXX.log)
|
||||||
|
export MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1)
|
||||||
|
export MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1)
|
||||||
|
|
||||||
set +xe
|
minio server --address localhost:$(($PORT_OFFSET + 9000)) ''${MINIO_DIR} &>''${MINIO_LOGFILE} &
|
||||||
fi
|
minio_pid=$!
|
||||||
|
|
||||||
if [[ -z "$UPLOAD_S3_HOST" ]]; then
|
export UPLOAD_S3_HOST=localhost
|
||||||
set -xe
|
export UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000))
|
||||||
|
export UPLOAD_S3_SSL=false
|
||||||
|
export UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}
|
||||||
|
export UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}
|
||||||
|
|
||||||
cleanup_minio() {
|
sleep 1
|
||||||
[[ -n "$minio_pid" ]] && kill $minio_pid
|
|
||||||
[[ -n "$minio_dir" ]] && rm -rvf ''${minio_dir}
|
|
||||||
[[ -n "MINIO_LOGFILE" ]] && rm -rvf ''${MINIO_LOGFILE}
|
|
||||||
}
|
|
||||||
|
|
||||||
export MINIO_DIR=$(mktemp -d)
|
set +xe
|
||||||
export MINIO_LOGFILE=$(mktemp --tmpdir minio.XXXXXX.log)
|
fi
|
||||||
export MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1)
|
|
||||||
export MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1)
|
|
||||||
|
|
||||||
minio server --address localhost:9000 ''${MINIO_DIR} &>''${MINIO_LOGFILE} &
|
set -xe
|
||||||
minio_pid=$?
|
|
||||||
|
|
||||||
sleep 1
|
cat >> ''${basePath}/.develop.env <<EOF
|
||||||
|
PORT_OFFSET=''${PORT_OFFSET}
|
||||||
|
|
||||||
export UPLOAD_S3_HOST=localhost UPLOAD_S3_PORT=9000 UPLOAD_S3_SSL=false UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY} UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}
|
PGHOST=''${pgSockDir}
|
||||||
|
PGLOG=''${pgLogFile}
|
||||||
|
|
||||||
set +xe
|
WIDGET_MEMCACHED_HOST=localhost
|
||||||
fi
|
WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211))
|
||||||
|
|
||||||
if [ -n "$ZSH_VERSION" ]; then
|
SESSION_MEMCACHED_HOST=localhost
|
||||||
autoload -U +X compinit && compinit
|
SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212))
|
||||||
autoload -U +X bashcompinit && bashcompinit
|
|
||||||
fi
|
|
||||||
eval "$(stack --bash-completion-script stack)"
|
|
||||||
|
|
||||||
${oldAttrs.shellHook}
|
MEMCACHED_HOST=localhost
|
||||||
'';
|
MEMCACHED_PORT=$(($PORT_OFFSET + 11212))
|
||||||
};
|
|
||||||
|
|
||||||
dummy = pkgs.stdenv.mkDerivation {
|
MINIO_DIR=''${MINIO_DIR}
|
||||||
name = "interactive-uniworx-environment";
|
MINIO_LOGFILE=''${MINIO_LOGFILE}
|
||||||
shellHook = "";
|
UPLOAD_S3_HOST=localhost
|
||||||
};
|
UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000))
|
||||||
in pkgs.stdenv.lib.overrideDerivation dummy override
|
UPLOAD_S3_SSL=false
|
||||||
#pkgs.stdenv.lib.overrideDerivation drv.env override
|
UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}
|
||||||
|
UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}
|
||||||
|
EOF
|
||||||
|
|
||||||
|
set +xe
|
||||||
|
|
||||||
|
if [ -n "$ZSH_VERSION" ]; then
|
||||||
|
autoload -U +X compinit && compinit
|
||||||
|
autoload -U +X bashcompinit && bashcompinit
|
||||||
|
fi
|
||||||
|
eval "$(stack --bash-completion-script stack)"
|
||||||
|
|
||||||
|
$(getent passwd $USER | cut -d: -f 7)
|
||||||
|
'';
|
||||||
|
in pkgs.mkShell {
|
||||||
|
name = "uni2work";
|
||||||
|
|
||||||
|
nativeBuildInputs = [develop] ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
|
||||||
|
}
|
||||||
|
|||||||
@ -88,6 +88,10 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
|||||||
fromPathPiece = fmap CI.mk . fromPathPiece
|
fromPathPiece = fmap CI.mk . fromPathPiece
|
||||||
toPathPiece = toPathPiece . CI.original
|
toPathPiece = toPathPiece . CI.original
|
||||||
|
|
||||||
|
instance PathPiece [CI Char] where
|
||||||
|
fromPathPiece = fmap (map CI.mk . (unpack :: Text -> [Char])) . fromPathPiece
|
||||||
|
toPathPiece = toPathPiece . (pack :: [Char] -> Text) . map CI.original
|
||||||
|
|
||||||
instance ToHttpApiData s => ToHttpApiData (CI s) where
|
instance ToHttpApiData s => ToHttpApiData (CI s) where
|
||||||
toUrlPiece = toUrlPiece . CI.original
|
toUrlPiece = toUrlPiece . CI.original
|
||||||
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
|
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
|
||||||
|
|||||||
@ -1967,7 +1967,9 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro
|
|||||||
|
|
||||||
evalWorkflowRoleFor' :: forall m backend.
|
evalWorkflowRoleFor' :: forall m backend.
|
||||||
( HasCallStack
|
( HasCallStack
|
||||||
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
, MonadAP (ReaderT backend m), MonadIO m
|
, MonadAP (ReaderT backend m), MonadIO m
|
||||||
|
, MonadThrow m
|
||||||
, BackendCompatible SqlReadBackend backend
|
, BackendCompatible SqlReadBackend backend
|
||||||
)
|
)
|
||||||
=> (forall m'. MonadAP m' => AuthTagsEval m')
|
=> (forall m'. MonadAP m' => AuthTagsEval m')
|
||||||
@ -2006,7 +2008,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
|
|||||||
WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do
|
WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do
|
||||||
uid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
uid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||||
wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
|
wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
|
||||||
WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
|
Entity _ WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift $ getWorkflowWorkflowState wwId
|
||||||
|
-- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
|
||||||
let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
|
let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
|
||||||
unless (uid `Set.member` uids) $
|
unless (uid `Set.member` uids) $
|
||||||
throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
|
throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
|
||||||
@ -2015,6 +2018,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
|
|||||||
|
|
||||||
evalWorkflowRoleFor :: ( HasCallStack
|
evalWorkflowRoleFor :: ( HasCallStack
|
||||||
, MonadAP (ReaderT backend m), MonadIO m
|
, MonadAP (ReaderT backend m), MonadIO m
|
||||||
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
|
, MonadThrow m
|
||||||
, BackendCompatible SqlReadBackend backend
|
, BackendCompatible SqlReadBackend backend
|
||||||
)
|
)
|
||||||
=> Maybe UserId
|
=> Maybe UserId
|
||||||
@ -2038,8 +2043,9 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
|
|||||||
|
|
||||||
hasWorkflowRole :: ( HasCallStack
|
hasWorkflowRole :: ( HasCallStack
|
||||||
, MonadAP (ReaderT backend m)
|
, MonadAP (ReaderT backend m)
|
||||||
, BackendCompatible SqlReadBackend backend
|
|
||||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
|
, MonadThrow m
|
||||||
|
, BackendCompatible SqlReadBackend backend
|
||||||
)
|
)
|
||||||
=> Maybe WorkflowWorkflowId
|
=> Maybe WorkflowWorkflowId
|
||||||
-> WorkflowRole UserId
|
-> WorkflowRole UserId
|
||||||
@ -2065,7 +2071,7 @@ mayViewWorkflowAction' :: forall backend m fileid.
|
|||||||
-> WorkflowAction fileid UserId
|
-> WorkflowAction fileid UserId
|
||||||
-> WriterT (Set AuthTag) (ReaderT backend m) Bool
|
-> WriterT (Set AuthTag) (ReaderT backend m) Bool
|
||||||
mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
||||||
WorkflowWorkflow{..} <- MaybeT . lift $ get wwId
|
Entity _ WorkflowWorkflow{..} <- MaybeT . lift $ getWorkflowWorkflowState wwId
|
||||||
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||||
cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId
|
cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId
|
||||||
WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||||
|
|||||||
@ -326,7 +326,7 @@ postAdminFeaturesR = do
|
|||||||
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
|
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
|
||||||
dbtSQLQuery = return
|
dbtSQLQuery = return
|
||||||
dbtRowKey = (E.^. StudyDegreeKey)
|
dbtRowKey = (E.^. StudyDegreeKey)
|
||||||
dbtProj = return
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = formColonnade $ mconcat
|
dbtColonnade = formColonnade $ mconcat
|
||||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
||||||
, sortable (Just "name") (i18nCell MsgTableDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
|
, sortable (Just "name") (i18nCell MsgTableDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
|
||||||
@ -356,7 +356,7 @@ postAdminFeaturesR = do
|
|||||||
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
|
||||||
dbtSQLQuery = return
|
dbtSQLQuery = return
|
||||||
dbtRowKey = (E.^. StudyTermsKey)
|
dbtRowKey = (E.^. StudyTermsKey)
|
||||||
dbtProj field@(view _dbrOutput -> Entity fId _) = do
|
dbtProj = dbtProjSimple $ \field@(Entity fId _) -> do
|
||||||
fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
|
fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
|
||||||
E.where_ . E.exists . E.from $ \schoolTerms ->
|
E.where_ . E.exists . E.from $ \schoolTerms ->
|
||||||
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
||||||
@ -368,7 +368,7 @@ postAdminFeaturesR = do
|
|||||||
E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
|
E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
|
||||||
E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
|
E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
|
||||||
return terms
|
return terms
|
||||||
return $ field & _dbrOutput %~ (, fieldParents, fieldSchools)
|
return (field, fieldParents, fieldSchools)
|
||||||
dbtColonnade = formColonnade $ mconcat
|
dbtColonnade = formColonnade $ mconcat
|
||||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
|
||||||
, sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
|
, sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
|
||||||
@ -416,7 +416,7 @@ postAdminFeaturesR = do
|
|||||||
dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
|
||||||
dbtSQLQuery = return
|
dbtSQLQuery = return
|
||||||
dbtRowKey = (E.^. StudyTermNameCandidateId)
|
dbtRowKey = (E.^. StudyTermNameCandidateId)
|
||||||
dbtProj = return
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
|
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
|
||||||
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
|
||||||
@ -459,7 +459,7 @@ postAdminFeaturesR = do
|
|||||||
E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
|
E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
|
||||||
return (candidate, parent, child)
|
return (candidate, parent, child)
|
||||||
dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
|
dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
|
||||||
dbtProj = return
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
|
[ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
|
||||||
, sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
|
, sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
|
||||||
@ -502,7 +502,7 @@ postAdminFeaturesR = do
|
|||||||
E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
|
E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
|
||||||
return (candidate, sterm)
|
return (candidate, sterm)
|
||||||
dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
|
dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
|
||||||
dbtProj = return
|
dbtProj = dbtProjId
|
||||||
dbtColonnade = formColonnade $ mconcat
|
dbtColonnade = formColonnade $ mconcat
|
||||||
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
|
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
|
||||||
, sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
|
||||||
|
|||||||
@ -77,8 +77,10 @@ getAllocationListR = do
|
|||||||
<*> view (queryAvailable muid ata now)
|
<*> view (queryAvailable muid ata now)
|
||||||
<*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid)
|
<*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid)
|
||||||
|
|
||||||
dbtProj :: DBRow _ -> DB AllocationTableData
|
dbtProj :: _ AllocationTableData
|
||||||
dbtProj = return . over (_dbrOutput . _2) (fromIntegral . E.unValue) . over (_dbrOutput . _3) (fromIntegral . E.unValue)
|
dbtProj = dbtProjId
|
||||||
|
<&> _dbrOutput . _2 %~ fromIntegral . E.unValue
|
||||||
|
<&> _dbrOutput . _3 %~ fromIntegral . E.unValue
|
||||||
|
|
||||||
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
|
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
|
||||||
|
|
||||||
|
|||||||
@ -187,7 +187,7 @@ postAUsersR tid ssh ash = do
|
|||||||
, assigned
|
, assigned
|
||||||
, vetoed)
|
, vetoed)
|
||||||
dbtRowKey = views queryAllocationUser (E.^. AllocationUserId)
|
dbtRowKey = views queryAllocationUser (E.^. AllocationUserId)
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
dbtProj = dbtProjSimple . runReaderT $ do
|
||||||
feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey
|
feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey
|
||||||
(,,,,,)
|
(,,,,,)
|
||||||
<$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
<$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||||
|
|||||||
@ -271,8 +271,8 @@ postCApplicationsR tid ssh csh = do
|
|||||||
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
|
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
|
||||||
)
|
)
|
||||||
|
|
||||||
dbtProj :: DBRow _ -> DB CourseApplicationsTableData
|
dbtProj :: _ CourseApplicationsTableData
|
||||||
dbtProj = traverse $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do
|
dbtProj = dbtProjSimple $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do
|
||||||
feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey)
|
feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey)
|
||||||
return (application, user, hasFiles, allocation, isParticipant, feats)
|
return (application, user, hasFiles, allocation, isParticipant, feats)
|
||||||
|
|
||||||
|
|||||||
@ -90,8 +90,8 @@ makeCourseTable whereClause colChoices psValidator = do
|
|||||||
return user
|
return user
|
||||||
isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course
|
isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course
|
||||||
E.&&. E.just (user E.^. UserId) E.==. E.val muid
|
E.&&. E.just (user E.^. UserId) E.==. E.val muid
|
||||||
dbtProj :: DBRow _ -> DB CourseTableData
|
dbtProj :: _ CourseTableData
|
||||||
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
|
dbtProj = dbtProjSimple $ \(course, E.Value participants, E.Value registered, school) -> do
|
||||||
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
||||||
courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
|
courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
|
||||||
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
|
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
|
||||||
|
|||||||
@ -169,7 +169,7 @@ getCShowR tid ssh csh = do
|
|||||||
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
|
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
|
||||||
return (tutorial, showRoom)
|
return (tutorial, showRoom)
|
||||||
dbtRowKey = (E.^. TutorialId)
|
dbtRowKey = (E.^. TutorialId)
|
||||||
dbtProj = traverse $ return . over _2 E.unValue
|
dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
||||||
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||||
|
|||||||
@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
|
|||||||
]
|
]
|
||||||
return exam
|
return exam
|
||||||
dbtRowKey = (E.^. ExamId)
|
dbtRowKey = (E.^. ExamId)
|
||||||
dbtProj = traverse $ \exam@(Entity eId _) -> do
|
dbtProj = dbtProjSimple $ \exam@(Entity eId _) -> do
|
||||||
registration <- getBy $ UniqueExamRegistration eId uid
|
registration <- getBy $ UniqueExamRegistration eId uid
|
||||||
occurrence <- runMaybeT $ do
|
occurrence <- runMaybeT $ do
|
||||||
Entity _ ExamRegistration{..} <- hoistMaybe registration
|
Entity _ ExamRegistration{..} <- hoistMaybe registration
|
||||||
@ -444,7 +444,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
|
|||||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
||||||
return (tutorial, tutorialParticipant)
|
return (tutorial, tutorialParticipant)
|
||||||
dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId
|
dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId
|
||||||
dbtProj = traverse $ \(tutorial, tutorialParticipant) -> do
|
dbtProj = dbtProjSimple $ \(tutorial, tutorialParticipant) -> do
|
||||||
tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey)
|
E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey)
|
||||||
|
|||||||
@ -375,7 +375,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
|||||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
||||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||||
dbtProj = traverse $ \(user, participant, E.Value userNoteId, subGroup) -> do
|
dbtProj = dbtProjSimple $ \(user, participant, E.Value userNoteId, subGroup) -> do
|
||||||
tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
|
tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
|
||||||
exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
|
exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
|
||||||
subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
||||||
|
|||||||
@ -29,7 +29,7 @@ mkExamTable (Entity cid Course{..}) = do
|
|||||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||||
return exam
|
return exam
|
||||||
dbtRowKey = (E.^. ExamId)
|
dbtRowKey = (E.^. ExamId)
|
||||||
dbtProj = return
|
dbtProj = dbtProjFilteredPostId
|
||||||
dbtColonnade = dbColonnade . mconcat $ catMaybes
|
dbtColonnade = dbColonnade . mconcat $ catMaybes
|
||||||
[ Just . sortable (Just "name") (i18nCell MsgTableExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
|
[ Just . sortable (Just "name") (i18nCell MsgTableExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
|
||||||
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
|
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
|
||||||
@ -61,7 +61,7 @@ mkExamTable (Entity cid Course{..}) = do
|
|||||||
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
dbtFilter = singletonMap "may-read" . FilterProjected $
|
dbtFilter = singletonMap "may-read" . mkFilterProjectedPost $
|
||||||
\(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
|
\(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
|
||||||
-> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
|
-> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
|
||||||
dbtFilterUI = const mempty
|
dbtFilterUI = const mempty
|
||||||
|
|||||||
@ -454,7 +454,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
|
|
||||||
return (examRegistration, user, occurrence, examBonus', examResult, courseUserNote)
|
return (examRegistration, user, occurrence, examBonus', examResult, courseUserNote)
|
||||||
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
dbtProj = dbtProjSimple . runReaderT $
|
||||||
(,,,,,,,)
|
(,,,,,,,)
|
||||||
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5
|
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5
|
||||||
<*> getExamParts
|
<*> getExamParts
|
||||||
|
|||||||
@ -302,8 +302,8 @@ postEGradesR tid ssh csh examn = do
|
|||||||
return (examResult, user, occurrence, examRegistration, isSynced)
|
return (examResult, user, occurrence, examRegistration, isSynced)
|
||||||
dbtRowKey = views queryExamResult (E.^. ExamResultId)
|
dbtRowKey = views queryExamResult (E.^. ExamResultId)
|
||||||
|
|
||||||
dbtProj :: DBRow _ -> DB ExamUserTableData
|
dbtProj :: _ ExamUserTableData
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
dbtProj = dbtProjSimple . runReaderT $
|
||||||
(,,,,,,)
|
(,,,,,,)
|
||||||
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value)
|
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value)
|
||||||
<*> getSynchronised
|
<*> getSynchronised
|
||||||
|
|||||||
@ -18,6 +18,22 @@ import qualified Colonnade
|
|||||||
import qualified Data.Conduit.Combinators as C
|
import qualified Data.Conduit.Combinators as C
|
||||||
|
|
||||||
|
|
||||||
|
data ExamsTableFilterProj = ExamsTableFilterProj
|
||||||
|
{ etProjFilterMayAccess :: Maybe Bool
|
||||||
|
, etProjFilterHasResults :: Maybe Bool
|
||||||
|
, etProjFilterIsSynced :: Maybe Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Default ExamsTableFilterProj where
|
||||||
|
def = ExamsTableFilterProj
|
||||||
|
{ etProjFilterMayAccess = Nothing
|
||||||
|
, etProjFilterHasResults = Nothing
|
||||||
|
, etProjFilterIsSynced = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
|
makeLenses_ ''ExamsTableFilterProj
|
||||||
|
|
||||||
|
|
||||||
type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam))
|
type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam))
|
||||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
|
||||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity School))
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity School))
|
||||||
@ -101,12 +117,33 @@ getEOExamsR = do
|
|||||||
return (exam, course, school, externalExam)
|
return (exam, course, school, externalExam)
|
||||||
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
|
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
|
||||||
|
|
||||||
dbtProj :: DBRow _ -> DB ExamsTableData
|
-- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
-- | Just exam <- r ^? resultExam . _entityVal
|
||||||
exam <- view _1
|
-- , Just course <- r ^? resultCourse . _entityVal
|
||||||
course <- view _2
|
-- -> hasReadAccessTo . urlRoute $ examLink course exam
|
||||||
school <- view _3
|
-- | Just eexam <- r ^? resultExternalExam . _entityVal
|
||||||
externalExam <- view _4
|
-- -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
|
||||||
|
-- | otherwise
|
||||||
|
-- -> return $ error "Got neither exam nor externalExam in result"
|
||||||
|
-- , singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool)
|
||||||
|
-- , singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool)
|
||||||
|
-- ]
|
||||||
|
|
||||||
|
dbtProj :: _ ExamsTableData
|
||||||
|
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do
|
||||||
|
exam <- view $ _dbtProjRow . _dbrOutput . _1
|
||||||
|
course <- view $ _dbtProjRow . _dbrOutput . _2
|
||||||
|
school <- view $ _dbtProjRow . _dbrOutput . _3
|
||||||
|
externalExam <- view $ _dbtProjRow . _dbrOutput . _4
|
||||||
|
|
||||||
|
forMM_ (view $ _dbtProjFilter . _etProjFilterMayAccess) $ \b -> if
|
||||||
|
| Just (Entity _ exam') <- exam
|
||||||
|
, Just (Entity _ course') <- course
|
||||||
|
-> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ examLink course' exam'
|
||||||
|
| Just (Entity _ eexam) <- externalExam
|
||||||
|
-> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ externalExamLink eexam
|
||||||
|
| otherwise
|
||||||
|
-> error "Got neither exam nor externalExam in result"
|
||||||
|
|
||||||
let
|
let
|
||||||
getExamResults = for_ exam $ \(Entity examId _) -> E.selectSource . E.from $ \examResult -> do
|
getExamResults = for_ exam $ \(Entity examId _) -> E.selectSource . E.from $ \examResult -> do
|
||||||
@ -119,7 +156,12 @@ getEOExamsR = do
|
|||||||
return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult
|
return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult
|
||||||
getResults = getExamResults >> getExternalExamResults
|
getResults = getExamResults >> getExternalExamResults
|
||||||
foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1)
|
foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1)
|
||||||
(Sum resultCount, Sum syncedCount) <- lift . runConduit $ getResults .| C.foldMap foldResult
|
(Sum resultCount, Sum syncedCount) <- lift . lift . runConduit $ getResults .| C.foldMap foldResult
|
||||||
|
|
||||||
|
forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) $ \b ->
|
||||||
|
guard $ b == (resultCount > 0)
|
||||||
|
forMM_ (view $ _dbtProjFilter . _etProjFilterIsSynced) $ \b ->
|
||||||
|
guard $ b == (syncedCount >= resultCount)
|
||||||
|
|
||||||
case (exam, course, school, externalExam) of
|
case (exam, course, school, externalExam) of
|
||||||
(Just exam', Just course', Just school', Nothing) -> return
|
(Just exam', Just course', Just school', Nothing) -> return
|
||||||
@ -189,16 +231,9 @@ getEOExamsR = do
|
|||||||
]
|
]
|
||||||
|
|
||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if
|
[ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny
|
||||||
| Just exam <- r ^? resultExam . _entityVal
|
, singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny
|
||||||
, Just course <- r ^? resultCourse . _entityVal
|
, singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny
|
||||||
-> hasReadAccessTo . urlRoute $ examLink course exam
|
|
||||||
| Just eexam <- r ^? resultExternalExam . _entityVal
|
|
||||||
-> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
|
|
||||||
| otherwise
|
|
||||||
-> return $ error "Got neither exam nor externalExam in result"
|
|
||||||
, singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool)
|
|
||||||
, singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool)
|
|
||||||
]
|
]
|
||||||
dbtFilterUI = mconcat
|
dbtFilterUI = mconcat
|
||||||
[ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised)
|
[ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised)
|
||||||
|
|||||||
@ -46,7 +46,7 @@ getEExamListR = do
|
|||||||
|
|
||||||
return (eexam, school)
|
return (eexam, school)
|
||||||
dbtRowKey = queryEExam >>> (E.^. ExternalExamId)
|
dbtRowKey = queryEExam >>> (E.^. ExternalExamId)
|
||||||
dbtProj = return
|
dbtProj = dbtProjFilteredPostId
|
||||||
dbtColonnade = widgetColonnade $ mconcat
|
dbtColonnade = widgetColonnade $ mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm
|
||||||
, sortable (Just "school") (i18nCell MsgTableSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName
|
, sortable (Just "school") (i18nCell MsgTableSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName
|
||||||
@ -60,7 +60,7 @@ getEExamListR = do
|
|||||||
, ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName))
|
, ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName))
|
||||||
]
|
]
|
||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$>
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$>
|
||||||
hasReadAccessTo (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) :: DB Bool
|
hasReadAccessTo (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) :: DB Bool
|
||||||
]
|
]
|
||||||
dbtFilterUI = const mempty
|
dbtFilterUI = const mempty
|
||||||
|
|||||||
@ -51,6 +51,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
|
|||||||
hfReferer' <- wopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
|
hfReferer' <- wopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
|
||||||
hfUserId' <- multiActionW identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
|
hfUserId' <- multiActionW identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
|
||||||
hfSubject' <- wopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
|
hfSubject' <- wopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
|
||||||
|
wformMessage =<< messageWidget Info $(i18nWidgetFile "help-instructions")
|
||||||
hfRequest' <- case sessErr of
|
hfRequest' <- case sessErr of
|
||||||
Nothing -> fmap Just <$> wreq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
|
Nothing -> fmap Just <$> wreq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
|
||||||
Just _ -> wopt htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
|
Just _ -> wopt htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
|
||||||
|
|||||||
@ -111,7 +111,7 @@ getMaterialListR tid ssh csh = do
|
|||||||
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
||||||
return (material, filesNum)
|
return (material, filesNum)
|
||||||
, dbtRowKey = (E.^. MaterialId)
|
, dbtRowKey = (E.^. MaterialId)
|
||||||
, dbtProj = return
|
, dbtProj = dbtProjFilteredPostId
|
||||||
, dbtColonnade = widgetColonnade $ mconcat
|
, dbtColonnade = widgetColonnade $ mconcat
|
||||||
[ -- dbRow,
|
[ -- dbRow,
|
||||||
sortable (Just "type") (i18nCell MsgMaterialType)
|
sortable (Just "type") (i18nCell MsgMaterialType)
|
||||||
@ -138,7 +138,7 @@ getMaterialListR tid ssh csh = do
|
|||||||
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
|
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
|
||||||
]
|
]
|
||||||
, dbtFilter = mconcat
|
, dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) dbr
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr
|
||||||
-> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
|
-> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
|
||||||
]
|
]
|
||||||
, dbtFilterUI = mempty
|
, dbtFilterUI = mempty
|
||||||
@ -237,7 +237,7 @@ getMShowR tid ssh csh mnm = do
|
|||||||
in anchorCellM matLink wgt
|
in anchorCellM matLink wgt
|
||||||
, materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
|
, materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
|
||||||
]
|
]
|
||||||
, dbtProj = return
|
, dbtProj = dbtProjId
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
, dbtParams = def
|
, dbtParams = def
|
||||||
, dbtFilter = mempty
|
, dbtFilter = mempty
|
||||||
|
|||||||
@ -161,7 +161,7 @@ newsUpcomingSheets uid = do
|
|||||||
{ dbtSQLQuery = tableData
|
{ dbtSQLQuery = tableData
|
||||||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||||
, dbtColonnade = colonnade
|
, dbtColonnade = colonnade
|
||||||
, dbtProj = return
|
, dbtProj = dbtProjFilteredPostId
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
[ ( "term"
|
[ ( "term"
|
||||||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||||
@ -183,7 +183,7 @@ newsUpcomingSheets uid = do
|
|||||||
)
|
)
|
||||||
]
|
]
|
||||||
, dbtFilter = mconcat
|
, dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
||||||
let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
|
let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
|
||||||
, E.Value SchoolId
|
, E.Value SchoolId
|
||||||
, E.Value CourseShorthand
|
, E.Value CourseShorthand
|
||||||
@ -252,7 +252,7 @@ newsUpcomingExams uid = do
|
|||||||
E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden)
|
E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden)
|
||||||
return (course, exam, register, occurrence, showRoom)
|
return (course, exam, register, occurrence, showRoom)
|
||||||
dbtRowKey = queryExam >>> (E.^. ExamId)
|
dbtRowKey = queryExam >>> (E.^. ExamId)
|
||||||
dbtProj = return
|
dbtProj = dbtProjFilteredPostId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||||
msgCell courseTerm
|
msgCell courseTerm
|
||||||
@ -323,7 +323,7 @@ newsUpcomingExams uid = do
|
|||||||
))
|
))
|
||||||
]
|
]
|
||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
||||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||||
Entity _ Course{..} = view lensCourse dbrOutput
|
Entity _ Course{..} = view lensCourse dbrOutput
|
||||||
in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool
|
in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool
|
||||||
|
|||||||
@ -504,7 +504,7 @@ mkOwnedCoursesTable =
|
|||||||
, course E.^. CourseShorthand
|
, course E.^. CourseShorthand
|
||||||
)
|
)
|
||||||
dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
|
dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
|
||||||
dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
|
dbtProj = dbtProjId <&> _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
||||||
|
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm & cellAttrs .~ [("priority","0")]) $ do
|
[ sortable (Just "term") (i18nCell MsgTableTerm & cellAttrs .~ [("priority","0")]) $ do
|
||||||
@ -556,7 +556,7 @@ mkEnrolledCoursesTable =
|
|||||||
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||||
return (course, participant E.^. CourseParticipantRegistration)
|
return (course, participant E.^. CourseParticipantRegistration)
|
||||||
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||||
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
|
, dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
|
||||||
, dbtColonnade = mconcat
|
, dbtColonnade = mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||||
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
|
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
|
||||||
@ -620,10 +620,10 @@ mkSubmissionTable =
|
|||||||
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
|
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
|
||||||
return . E.max_ $ subEdit E.^. SubmissionEditTime
|
return . E.max_ $ subEdit E.^. SubmissionEditTime
|
||||||
|
|
||||||
dbtProj x = return $ x
|
dbtProj = dbtProjId
|
||||||
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
<&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
||||||
& _dbrOutput . _2 %~ E.unValue
|
<&> _dbrOutput . _2 %~ E.unValue
|
||||||
& _dbrOutput . _4 %~ E.unValue
|
<&> _dbrOutput . _4 %~ E.unValue
|
||||||
|
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||||
@ -697,8 +697,8 @@ mkSubmissionGroupTable =
|
|||||||
return (crse, sgroup)
|
return (crse, sgroup)
|
||||||
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
||||||
|
|
||||||
dbtProj x = return $ x
|
dbtProj = dbtProjId
|
||||||
& _dbrOutput . _1 %~ $(E.unValueN 3)
|
<&> _dbrOutput . _1 %~ $(E.unValueN 3)
|
||||||
|
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||||
@ -764,9 +764,9 @@ mkCorrectionsTable =
|
|||||||
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
||||||
dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
|
dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
|
||||||
|
|
||||||
dbtProj x = return $ x
|
dbtProj = dbtProjId
|
||||||
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
<&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
||||||
& _dbrOutput . _2 %~ E.unValue
|
<&> _dbrOutput . _2 %~ E.unValue
|
||||||
|
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||||
|
|||||||
@ -19,8 +19,7 @@ getSchoolListR = do
|
|||||||
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
|
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
|
||||||
dbtSQLQuery = return
|
dbtSQLQuery = return
|
||||||
|
|
||||||
dbtProj :: DBRow _ -> DB (DBRow (Entity School))
|
dbtProj = dbtProjId
|
||||||
dbtProj = return
|
|
||||||
|
|
||||||
dbtRowKey = (E.^. SchoolId)
|
dbtRowKey = (E.^. SchoolId)
|
||||||
|
|
||||||
|
|||||||
@ -129,7 +129,7 @@ getSheetListR tid ssh csh = do
|
|||||||
)
|
)
|
||||||
return (sheet, lastSheetEdit sheet, submission, existFiles)
|
return (sheet, lastSheetEdit sheet, submission, existFiles)
|
||||||
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||||
, dbtProj = return
|
, dbtProj = dbtProjFilteredPostId
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
[ ( "name"
|
[ ( "name"
|
||||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||||
@ -157,11 +157,11 @@ getSheetListR tid ssh csh = do
|
|||||||
-- )
|
-- )
|
||||||
]
|
]
|
||||||
, dbtFilter = mconcat
|
, dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
||||||
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
||||||
in (== b) <$> sheetFilter sheetName :: DB Bool
|
in (== b) <$> sheetFilter sheetName :: DB Bool
|
||||||
, singletonMap "rated" . FilterColumn $ \(Any b) -> (E.==. E.val b) . E.isJust . (E.?. SubmissionRatingTime) . querySubmission
|
, singletonMap "rated" . FilterColumn $ \(Any b) -> (E.==. E.val b) . E.isJust . (E.?. SubmissionRatingTime) . querySubmission
|
||||||
, singletonMap "is-exam" . FilterProjected $ \(Any b) DBRow{..} ->
|
, singletonMap "is-exam" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
||||||
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
||||||
in return $ is _ExamPartPoints sheetType == b :: DB Bool
|
in return $ is _ExamPartPoints sheetType == b :: DB Bool
|
||||||
]
|
]
|
||||||
|
|||||||
@ -71,12 +71,11 @@ getSShowR tid ssh csh shn = do
|
|||||||
{ dbtSQLQuery = fileData
|
{ dbtSQLQuery = fileData
|
||||||
, dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
|
, dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
|
||||||
, dbtColonnade = colonnadeFiles
|
, dbtColonnade = colonnadeFiles
|
||||||
, dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))
|
, dbtProj = (dbrOutput :: _ -> (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))) <$> dbtProjFilteredPostId
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
, dbtFilter = mconcat
|
, dbtFilter = mconcat
|
||||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{ dbrOutput = (E.Value fName, _ :: E.Value UTCTime, E.Value fType, _ :: E.Value (Maybe FileContentReference)) } ->
|
||||||
let (E.Value fName, _, E.Value fType, _) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))
|
(==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
|
||||||
in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
|
|
||||||
]
|
]
|
||||||
, dbtFilterUI = mempty
|
, dbtFilterUI = mempty
|
||||||
, dbtIdent = "files" :: Text
|
, dbtIdent = "files" :: Text
|
||||||
|
|||||||
@ -545,7 +545,7 @@ submissionHelper tid ssh csh shn mcid = do
|
|||||||
{ dbtSQLQuery = submissionFiles smid
|
{ dbtSQLQuery = submissionFiles smid
|
||||||
, dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId)
|
, dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId)
|
||||||
, dbtColonnade = colonnadeFiles cid
|
, dbtColonnade = colonnadeFiles cid
|
||||||
, dbtProj = return . dbrOutput
|
, dbtProj = dbrOutput <$> dbtProjId
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
, dbtIdent = "files" :: Text
|
, dbtIdent = "files" :: Text
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
|
|||||||
@ -37,6 +37,17 @@ import Database.Persist.Sql (updateWhereCount)
|
|||||||
import Data.List (genericLength)
|
import Data.List (genericLength)
|
||||||
|
|
||||||
|
|
||||||
|
newtype CorrectionTableFilterProj = CorrectionTableFilterProj
|
||||||
|
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Default CorrectionTableFilterProj where
|
||||||
|
def = CorrectionTableFilterProj
|
||||||
|
{ corrProjFilterSubmission = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
|
makeLenses_ ''CorrectionTableFilterProj
|
||||||
|
|
||||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||||
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
||||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -})
|
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -})
|
||||||
@ -225,9 +236,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
|||||||
)
|
)
|
||||||
in (submission, sheet, crse, corrector, lastEditQuery submission)
|
in (submission, sheet, crse, corrector, lastEditQuery submission)
|
||||||
)
|
)
|
||||||
dbtProj :: DBRow _ -> DB CorrectionTableData
|
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
|
||||||
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do
|
(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput
|
||||||
submittors <- E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
cid <- encrypt sId
|
||||||
|
forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria ->
|
||||||
|
let haystack = map CI.mk . unpack $ toPathPiece cid
|
||||||
|
in guard $ any (`isInfixOf` haystack) criteria
|
||||||
|
|
||||||
|
submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
||||||
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
|
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
|
||||||
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
|
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
|
||||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||||
@ -238,13 +254,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
|||||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
|
||||||
return . E.just $ submissionGroup E.^. SubmissionGroupName
|
return . E.just $ submissionGroup E.^. SubmissionGroupName
|
||||||
|
|
||||||
return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
|
return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
|
||||||
let
|
let
|
||||||
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
|
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
|
||||||
nonAnonymousAccess <- or2M
|
nonAnonymousAccess <- lift . lift $ or2M
|
||||||
(return $ not sheetAnonymousCorrection)
|
(return $ not sheetAnonymousCorrection)
|
||||||
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
||||||
cid <- encrypt sId
|
|
||||||
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
|
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
|
||||||
dbTable psValidator DBTable
|
dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery
|
{ dbtSQLQuery
|
||||||
@ -397,10 +414,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
|||||||
Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
|
Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
|
||||||
)
|
)
|
||||||
, ( "submission"
|
, ( "submission"
|
||||||
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
, FilterProjected (_corrProjFilterSubmission ?~)
|
||||||
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
-- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
||||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
-- let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
||||||
in any (`isInfixOf` cid) criteria'
|
-- criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||||
|
-- in any (`isInfixOf` cid) criteria'
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||||||
@ -662,7 +680,7 @@ postCorrectionsR = do
|
|||||||
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
|
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
|
||||||
termOptions = runDB $ do
|
termOptions = runDB $ do
|
||||||
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
courses <- selectList [] [Desc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||||
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
|
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
|
||||||
schoolOptions = runDB $ do
|
schoolOptions = runDB $ do
|
||||||
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||||
@ -671,8 +689,8 @@ postCorrectionsR = do
|
|||||||
psValidator = def
|
psValidator = def
|
||||||
& restrictCorrector
|
& restrictCorrector
|
||||||
& restrictAnonymous
|
& restrictAnonymous
|
||||||
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
& defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ]
|
||||||
-- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
|
& defaultFilter (singletonMap "israted" [toPathPiece False])
|
||||||
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
||||||
[ downloadAction
|
[ downloadAction
|
||||||
]
|
]
|
||||||
|
|||||||
@ -184,12 +184,8 @@ postMessageListR = do
|
|||||||
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
||||||
in cell . toWidget $ fromMaybe content summary
|
in cell . toWidget $ fromMaybe content summary
|
||||||
]
|
]
|
||||||
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
|
dbtProj = dbtProjSimple $ \smE@(Entity smId _) ->
|
||||||
smT <- (>>= view _2) <$> getSystemMessage smId
|
(smE, ) . (>>= view _2) <$> getSystemMessage smId
|
||||||
return DBRow
|
|
||||||
{ dbrOutput = (smE, smT)
|
|
||||||
, ..
|
|
||||||
}
|
|
||||||
psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
|
psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
|
||||||
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
|
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery
|
{ dbtSQLQuery
|
||||||
|
|||||||
@ -76,7 +76,7 @@ getTermShowR = do
|
|||||||
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
||||||
E.&&. mayViewCourse muid ata now course Nothing
|
E.&&. mayViewCourse muid ata now course Nothing
|
||||||
dbtRowKey = (E.^. TermId)
|
dbtRowKey = (E.^. TermId)
|
||||||
dbtProj = return . dbrOutput
|
dbtProj = dbrOutput <$> dbtProjId
|
||||||
dbtColonnade = widgetColonnade $ mconcat
|
dbtColonnade = widgetColonnade $ mconcat
|
||||||
[ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
|
[ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
|
||||||
-> cell $ do
|
-> cell $ do
|
||||||
|
|||||||
@ -38,7 +38,7 @@ getCTutorialListR tid ssh csh = do
|
|||||||
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
|
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
|
||||||
return (tutorial, participants, showRoom)
|
return (tutorial, participants, showRoom)
|
||||||
dbtRowKey = (E.^. TutorialId)
|
dbtRowKey = (E.^. TutorialId)
|
||||||
dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
|
dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
||||||
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||||
|
|||||||
@ -143,7 +143,7 @@ postUsersR = do
|
|||||||
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||||
, dbtRowKey = (E.^. UserId)
|
, dbtRowKey = (E.^. UserId)
|
||||||
, dbtColonnade
|
, dbtColonnade
|
||||||
, dbtProj = return
|
, dbtProj = dbtProjId
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
[ ( "name"
|
[ ( "name"
|
||||||
, SortColumn $ \user -> user E.^. UserSurname
|
, SortColumn $ \user -> user E.^. UserSurname
|
||||||
|
|||||||
@ -215,8 +215,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
|||||||
return (result, user, isSynced)
|
return (result, user, isSynced)
|
||||||
dbtRowKey = views queryResult (E.^. ExternalExamResultId)
|
dbtRowKey = views queryResult (E.^. ExternalExamResultId)
|
||||||
|
|
||||||
dbtProj :: DBRow _ -> DB ExternalExamUserTableData
|
dbtProj :: _ ExternalExamUserTableData
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
dbtProj = dbtProjSimple . runReaderT $
|
||||||
(,,,,)
|
(,,,,)
|
||||||
<$> view _1 <*> view _2 <*> view (_3 . _Value)
|
<$> view _1 <*> view _2 <*> view (_3 . _Value)
|
||||||
<*> getSynchronised
|
<*> getSynchronised
|
||||||
|
|||||||
@ -70,10 +70,10 @@ type OpticSortColumn' focus
|
|||||||
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
|
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
|
||||||
|
|
||||||
type OpticFilterColumn' t inp focus
|
type OpticFilterColumn' t inp focus
|
||||||
= forall r' filterMap.
|
= forall fs filterMap.
|
||||||
( IsMap filterMap
|
( IsMap filterMap
|
||||||
, ContainerKey filterMap ~ FilterKey
|
, ContainerKey filterMap ~ FilterKey
|
||||||
, MapValue filterMap ~ FilterColumn t r'
|
, MapValue filterMap ~ FilterColumn t fs
|
||||||
, IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
|
, IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
|
||||||
)
|
)
|
||||||
=> (forall focus'. Getting focus' t focus)
|
=> (forall focus'. Getting focus' t focus)
|
||||||
@ -500,37 +500,37 @@ defaultSortingByName =
|
|||||||
defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
|
defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
|
||||||
|
|
||||||
-- | Alias for sortUserName for consistency
|
-- | Alias for sortUserName for consistency
|
||||||
fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t r')
|
fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs)
|
||||||
fltrUserNameLink = fltrUserName
|
fltrUserNameLink = fltrUserName
|
||||||
|
|
||||||
fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
|
fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
|
||||||
where
|
where
|
||||||
queryName = queryUser >>> (E.^. UserDisplayName)
|
queryName = queryUser >>> (E.^. UserDisplayName)
|
||||||
|
|
||||||
fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
|
fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
|
||||||
where
|
where
|
||||||
queryName = queryUser >>> (E.^. UserDisplayName)
|
queryName = queryUser >>> (E.^. UserDisplayName)
|
||||||
|
|
||||||
fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
|
fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
|
||||||
|
|
||||||
fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
|
fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
|
||||||
|
|
||||||
-- | Search all names, i.e. DisplayName, Surname, EMail
|
-- | Search all names, i.e. DisplayName, Surname, EMail
|
||||||
fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
|
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
|
||||||
[ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
|
[ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
|
||||||
, mkContainsFilter $ queryUser >>> (E.^. UserSurname)
|
, mkContainsFilter $ queryUser >>> (E.^. UserSurname)
|
||||||
@ -579,7 +579,7 @@ fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo
|
|||||||
, IsString d
|
, IsString d
|
||||||
)
|
)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer))
|
fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer))
|
||||||
|
|
||||||
fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||||
@ -599,7 +599,7 @@ fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bo
|
|||||||
, IsString d
|
, IsString d
|
||||||
)
|
)
|
||||||
=> (a -> E.SqlExpr (Entity User))
|
=> (a -> E.SqlExpr (Entity User))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
|
fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
|
||||||
|
|
||||||
fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||||
@ -724,7 +724,7 @@ fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value B
|
|||||||
, IsString d
|
, IsString d
|
||||||
)
|
)
|
||||||
=> (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
|
=> (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
|
fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
|
||||||
|
|
||||||
fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||||
@ -742,7 +742,7 @@ fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
|
|||||||
, IsString d
|
, IsString d
|
||||||
)
|
)
|
||||||
=> (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
|
=> (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrField queryFeatures = ( "terms"
|
fltrField queryFeatures = ( "terms"
|
||||||
, FilterColumn $ anyFilter
|
, FilterColumn $ anyFilter
|
||||||
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName)
|
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName)
|
||||||
@ -763,10 +763,10 @@ sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -
|
|||||||
sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
|
sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
|
||||||
|
|
||||||
fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
|
fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
|
||||||
, IsString d
|
, IsString d
|
||||||
)
|
)
|
||||||
=> (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
|
=> (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||||
-> (d, FilterColumn t r')
|
-> (d, FilterColumn t fs)
|
||||||
fltrDegree queryFeatures = ( "degree"
|
fltrDegree queryFeatures = ( "degree"
|
||||||
, FilterColumn $ anyFilter
|
, FilterColumn $ anyFilter
|
||||||
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)
|
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)
|
||||||
|
|||||||
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||||
|
|
||||||
module Handler.Utils.Table.Pagination
|
module Handler.Utils.Table.Pagination
|
||||||
( module Handler.Utils.Table.Pagination.Types
|
( module Handler.Utils.Table.Pagination.Types
|
||||||
@ -7,14 +8,19 @@ module Handler.Utils.Table.Pagination
|
|||||||
, SortColumn(..), SortDirection(..)
|
, SortColumn(..), SortDirection(..)
|
||||||
, SortingSetting(..)
|
, SortingSetting(..)
|
||||||
, pattern SortAscBy, pattern SortDescBy
|
, pattern SortAscBy, pattern SortDescBy
|
||||||
, FilterColumn(..), IsFilterColumn
|
, FilterColumn(..), IsFilterColumn, IsFilterProjected
|
||||||
|
, mkFilterProjectedPost
|
||||||
|
, DBTProjFilterPost(..)
|
||||||
, DBRow(..), _dbrOutput, _dbrCount
|
, DBRow(..), _dbrOutput, _dbrCount
|
||||||
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
|
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
|
||||||
, module Handler.Utils.Table.Pagination.CsvColumnExplanations
|
, module Handler.Utils.Table.Pagination.CsvColumnExplanations
|
||||||
, DBCsvActionMode(..)
|
, DBCsvActionMode(..)
|
||||||
, DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
|
, DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
|
||||||
, DBTCsvEncode(..), DBTCsvDecode(..), DBTExtraRep(..)
|
, DBTCsvEncode(..), DBTCsvDecode(..), DBTExtraRep(..)
|
||||||
|
, DBTProjCtx(..), _dbtProjFilter, _dbtProjRow, _dbtProjRow'
|
||||||
, DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..)
|
, DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..)
|
||||||
|
, dbtProjId, dbtProjSimple
|
||||||
|
, dbtProjFilteredPostId, dbtProjFilteredPostSimple
|
||||||
, noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
|
, noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
|
||||||
, withCsvExtraRep
|
, withCsvExtraRep
|
||||||
, singletonFilter
|
, singletonFilter
|
||||||
@ -200,16 +206,50 @@ pattern SortDescBy :: SortingKey -> SortingSetting
|
|||||||
pattern SortDescBy key = SortingSetting key SortDesc
|
pattern SortDescBy key = SortingSetting key SortDesc
|
||||||
|
|
||||||
|
|
||||||
data FilterColumn t r' = forall a. IsFilterColumn t a => FilterColumn a
|
type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k')
|
||||||
| forall a. IsFilterProjected r' a => FilterProjected a
|
data DBRow r = forall k'. DBTableKey k' => DBRow
|
||||||
|
{ dbrKey :: k'
|
||||||
|
, dbrOutput :: r
|
||||||
|
, dbrCount :: Int64
|
||||||
|
}
|
||||||
|
|
||||||
filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
|
makeLenses_ ''DBRow
|
||||||
|
|
||||||
|
instance Functor DBRow where
|
||||||
|
fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
|
||||||
|
|
||||||
|
instance Foldable DBRow where
|
||||||
|
foldMap f DBRow{..} = f dbrOutput
|
||||||
|
|
||||||
|
instance Traversable DBRow where
|
||||||
|
traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount
|
||||||
|
|
||||||
|
|
||||||
|
newtype DBTProjFilterPost r' = DBTProjFilterPost { unDBTProjFilterPost :: r' -> DB Bool }
|
||||||
|
|
||||||
|
instance Default (DBTProjFilterPost r') where
|
||||||
|
def = mempty
|
||||||
|
|
||||||
|
instance Semigroup (DBTProjFilterPost r') where
|
||||||
|
DBTProjFilterPost f <> DBTProjFilterPost g = DBTProjFilterPost $ \r' -> f r' `and2M` g r'
|
||||||
|
|
||||||
|
instance Monoid (DBTProjFilterPost r') where
|
||||||
|
mempty = DBTProjFilterPost . const $ return True
|
||||||
|
|
||||||
|
|
||||||
|
data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
|
||||||
|
| forall a. IsFilterProjected fs a => FilterProjected a
|
||||||
|
|
||||||
|
filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
|
||||||
filterColumn (FilterColumn f) = Just $ filterColumn' f
|
filterColumn (FilterColumn f) = Just $ filterColumn' f
|
||||||
filterColumn _ = Nothing
|
filterColumn _ = Nothing
|
||||||
|
|
||||||
filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool
|
filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs)
|
||||||
filterProjected (FilterProjected f) = flip $ filterProjected' f
|
filterProjected (FilterProjected f) = filterProjected' f
|
||||||
filterProjected _ = \_ _ -> return True
|
filterProjected _ = const id
|
||||||
|
|
||||||
|
mkFilterProjectedPost :: forall r' a t. IsFilterProjectedPost r' a => a -> FilterColumn t (DBTProjFilterPost r')
|
||||||
|
mkFilterProjectedPost fin = FilterProjected $ \(ts :: [Text]) -> (<> filterProjectedPost' @r' fin ts)
|
||||||
|
|
||||||
class IsFilterColumn t a where
|
class IsFilterColumn t a where
|
||||||
filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
||||||
@ -223,21 +263,33 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
|||||||
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
||||||
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
|
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
|
||||||
|
|
||||||
class IsFilterProjected r' a where
|
class IsFilterProjected fs a where
|
||||||
filterProjected' :: a -> [Text] -> r' -> DB Bool
|
filterProjected' :: a -> [Text] -> (fs -> fs)
|
||||||
|
|
||||||
instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
|
instance IsFilterProjected fs (fs -> fs) where
|
||||||
filterProjected' fin _ _ = fin
|
filterProjected' fin _ = fin
|
||||||
|
|
||||||
instance IsFilterProjected r' Bool where
|
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected fs cont, MonoPointed l, Monoid l) => IsFilterProjected fs (l -> cont) where
|
||||||
filterProjected' fin _ _ = return fin
|
|
||||||
|
|
||||||
instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where
|
|
||||||
filterProjected' cont is' r = filterProjected' (cont r) is' r
|
|
||||||
|
|
||||||
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where
|
|
||||||
filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'
|
filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'
|
||||||
|
|
||||||
|
class IsFilterProjectedPost r' a where
|
||||||
|
filterProjectedPost' :: a -> [Text] -> DBTProjFilterPost r'
|
||||||
|
|
||||||
|
instance IsFilterProjectedPost r' Bool where
|
||||||
|
filterProjectedPost' fin _ = DBTProjFilterPost . const $ return fin
|
||||||
|
|
||||||
|
instance IsFilterProjectedPost r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
|
||||||
|
filterProjectedPost' fin _ = DBTProjFilterPost $ const fin
|
||||||
|
|
||||||
|
instance IsFilterProjectedPost r' (DBTProjFilterPost r') where
|
||||||
|
filterProjectedPost' fin _ = fin
|
||||||
|
|
||||||
|
instance IsFilterProjectedPost r' cont => IsFilterProjectedPost r' (r' -> cont) where
|
||||||
|
filterProjectedPost' cont is' = DBTProjFilterPost $ \r' -> let DBTProjFilterPost cont' = filterProjectedPost' (cont r') is' in cont' r'
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjectedPost r' cont, MonoPointed l, Monoid l) => IsFilterProjectedPost r' (l -> cont) where
|
||||||
|
filterProjectedPost' cont is' = filterProjectedPost' (cont $ is' ^. mono' _PathPiece) is'
|
||||||
|
|
||||||
|
|
||||||
data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
|
data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
|
||||||
deriving (Eq, Ord, Read, Show, Generic)
|
deriving (Eq, Ord, Read, Show, Generic)
|
||||||
@ -431,24 +483,17 @@ makeLenses_ ''DBCsvException
|
|||||||
|
|
||||||
instance (Typeable k', Show k') => Exception (DBCsvException k')
|
instance (Typeable k', Show k') => Exception (DBCsvException k')
|
||||||
|
|
||||||
|
|
||||||
type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k')
|
data DBTProjCtx fs r = DBTProjCtx
|
||||||
data DBRow r = forall k'. DBTableKey k' => DBRow
|
{ dbtProjFilter :: fs
|
||||||
{ dbrKey :: k'
|
, dbtProjRow :: DBRow r
|
||||||
, dbrOutput :: r
|
|
||||||
, dbrCount :: Int64
|
|
||||||
}
|
}
|
||||||
|
|
||||||
makeLenses_ ''DBRow
|
makeLenses_ ''DBTProjCtx
|
||||||
|
|
||||||
instance Functor DBRow where
|
_dbtProjRow' :: Lens' (DBTProjCtx () r) (DBRow r)
|
||||||
fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
|
_dbtProjRow' = _dbtProjRow
|
||||||
|
|
||||||
instance Foldable DBRow where
|
|
||||||
foldMap f DBRow{..} = f dbrOutput
|
|
||||||
|
|
||||||
instance Traversable DBRow where
|
|
||||||
traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount
|
|
||||||
|
|
||||||
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
|
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||||
|
|
||||||
@ -579,7 +624,7 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
|
|||||||
fromInner = maybe Map.empty $ Map.singleton key . pure
|
fromInner = maybe Map.empty $ Map.singleton key . pure
|
||||||
fromOuter = Map.lookup key >=> listToMaybe
|
fromOuter = Map.lookup key >=> listToMaybe
|
||||||
|
|
||||||
|
|
||||||
data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
|
data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
|
||||||
( ToNamedRecord csv, CsvColumnsExplained csv
|
( ToNamedRecord csv, CsvColumnsExplained csv
|
||||||
, DBTableKey k'
|
, DBTableKey k'
|
||||||
@ -628,19 +673,20 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
|
|||||||
, dbtCsvRenderException :: csvException -> DB Text
|
, dbtCsvRenderException :: csvException -> DB Text
|
||||||
}
|
}
|
||||||
|
|
||||||
data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar).
|
data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar) fs.
|
||||||
( ToSortable h, Functor h
|
( ToSortable h, Functor h
|
||||||
, E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
|
, E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
|
||||||
, PathPiece i, Eq i
|
, PathPiece i, Eq i
|
||||||
, E.From t
|
, E.From t
|
||||||
, AsCornice h p r' (DBCell m x) colonnade
|
, AsCornice h p r' (DBCell m x) colonnade
|
||||||
|
, Default fs
|
||||||
) => DBTable
|
) => DBTable
|
||||||
{ dbtSQLQuery :: t -> E.SqlQuery a
|
{ dbtSQLQuery :: t -> E.SqlQuery a
|
||||||
, dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
|
, dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
|
||||||
, dbtProj :: DBRow r -> DB r'
|
, dbtProj :: ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
, dbtColonnade :: colonnade
|
, dbtColonnade :: colonnade
|
||||||
, dbtSorting :: Map SortingKey (SortColumn t r')
|
, dbtSorting :: Map SortingKey (SortColumn t r')
|
||||||
, dbtFilter :: Map FilterKey (FilterColumn t r')
|
, dbtFilter :: Map FilterKey (FilterColumn t fs)
|
||||||
, dbtFilterUI :: DBFilterUI
|
, dbtFilterUI :: DBFilterUI
|
||||||
, dbtStyle :: DBStyle r'
|
, dbtStyle :: DBStyle r'
|
||||||
, dbtParams :: DBParams m x
|
, dbtParams :: DBParams m x
|
||||||
@ -652,6 +698,50 @@ data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar).
|
|||||||
|
|
||||||
type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
|
type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
|
||||||
|
|
||||||
|
dbtProjId' :: forall fs r r'.
|
||||||
|
DBRow r ~ r'
|
||||||
|
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
dbtProjId' = view _dbtProjRow
|
||||||
|
|
||||||
|
dbtProjId :: forall fs r r'.
|
||||||
|
( fs ~ (), DBRow r ~ r' )
|
||||||
|
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
dbtProjId = dbtProjId'
|
||||||
|
|
||||||
|
dbtProjSimple' :: forall fs r r' r''.
|
||||||
|
DBRow r'' ~ r'
|
||||||
|
=> (r -> DB r'')
|
||||||
|
-> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask
|
||||||
|
|
||||||
|
dbtProjSimple :: forall fs r r' r''.
|
||||||
|
( fs ~ (), DBRow r'' ~ r' )
|
||||||
|
=> (r -> DB r'')
|
||||||
|
-> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
dbtProjSimple = dbtProjSimple'
|
||||||
|
|
||||||
|
withFilteredPost :: forall fs r r'.
|
||||||
|
fs ~ DBTProjFilterPost r'
|
||||||
|
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
-> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
withFilteredPost proj = do
|
||||||
|
r' <- proj
|
||||||
|
p <- views _dbtProjFilter unDBTProjFilterPost
|
||||||
|
guardM . lift . lift $ p r'
|
||||||
|
return r'
|
||||||
|
|
||||||
|
dbtProjFilteredPostId :: forall fs r r'.
|
||||||
|
( fs ~ DBTProjFilterPost r', DBRow r ~ r' )
|
||||||
|
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
dbtProjFilteredPostId = withFilteredPost dbtProjId'
|
||||||
|
|
||||||
|
dbtProjFilteredPostSimple :: forall fs r r' r''.
|
||||||
|
( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
|
||||||
|
=> (r -> DB r'')
|
||||||
|
-> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||||
|
dbtProjFilteredPostSimple = withFilteredPost . dbtProjSimple'
|
||||||
|
|
||||||
|
|
||||||
noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
|
noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
|
||||||
noCsvEncode = Nothing
|
noCsvEncode = Nothing
|
||||||
|
|
||||||
@ -1115,7 +1205,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
| otherwise
|
| otherwise
|
||||||
= id
|
= id
|
||||||
|
|
||||||
allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter'
|
dbtProjFilter = ala Endo foldMap (psFilter' <&> \(f, args) -> filterProjected f args) def
|
||||||
|
|
||||||
sortProjected
|
sortProjected
|
||||||
| is _Just previousKeys
|
| is _Just previousKeys
|
||||||
@ -1130,7 +1220,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
adjustOrder SortDesc EQ = EQ
|
adjustOrder SortDesc EQ = EQ
|
||||||
adjustOrder SortDesc GT = LT
|
adjustOrder SortDesc GT = LT
|
||||||
|
|
||||||
(currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (assertMM allFilterProjected . lift . dbtProj) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'
|
(currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (\dbtProjRow -> runReaderT dbtProj DBTProjCtx{..}) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'
|
||||||
|
|
||||||
csvExample <- runMaybeT $ do
|
csvExample <- runMaybeT $ do
|
||||||
DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode
|
DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode
|
||||||
|
|||||||
@ -73,6 +73,7 @@ workflowEdgeForm :: ( MonadHandler m
|
|||||||
, MonadHandler m'
|
, MonadHandler m'
|
||||||
, HandlerSite m' ~ UniWorX
|
, HandlerSite m' ~ UniWorX
|
||||||
, MonadUnliftIO m'
|
, MonadUnliftIO m'
|
||||||
|
, MonadThrow m'
|
||||||
)
|
)
|
||||||
=> Either WorkflowInstanceId WorkflowWorkflowId
|
=> Either WorkflowInstanceId WorkflowWorkflowId
|
||||||
-> Maybe WorkflowEdgeForm
|
-> Maybe WorkflowEdgeForm
|
||||||
@ -80,7 +81,7 @@ workflowEdgeForm :: ( MonadHandler m
|
|||||||
workflowEdgeForm mwwId mPrev = runMaybeT $ do
|
workflowEdgeForm mwwId mPrev = runMaybeT $ do
|
||||||
MsgRenderer mr <- getMsgRenderer
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
|
||||||
ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId
|
ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getWorkflowWorkflowState) mwwId
|
||||||
let (scope, sharedGraphId) = case ctx' of
|
let (scope, sharedGraphId) = case ctx' of
|
||||||
Left (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope
|
Left (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope
|
||||||
, workflowInstanceGraph
|
, workflowInstanceGraph
|
||||||
|
|||||||
@ -97,4 +97,3 @@ sourceWorkflowActionInfos wwId wState = do
|
|||||||
let authCheck WorkflowActionInfo{..}
|
let authCheck WorkflowActionInfo{..}
|
||||||
= mayViewWorkflowAction mAuthId wwId waiAction
|
= mayViewWorkflowAction mAuthId wwId waiAction
|
||||||
yieldMany (workflowActionInfos wState) .| C.filterM authCheck
|
yieldMany (workflowActionInfos wState) .| C.filterM authCheck
|
||||||
|
|
||||||
|
|||||||
@ -66,7 +66,7 @@ getAdminWorkflowDefinitionListR = do
|
|||||||
|
|
||||||
return (workflowDefinition, workflowInstanceCount, workflowCount)
|
return (workflowDefinition, workflowInstanceCount, workflowCount)
|
||||||
dbtRowKey = (E.^. WorkflowDefinitionId)
|
dbtRowKey = (E.^. WorkflowDefinitionId)
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
dbtProj = dbtProjFilteredPostSimple . runReaderT $ do
|
||||||
wd@(Entity wdId _) <- view _1
|
wd@(Entity wdId _) <- view _1
|
||||||
descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do
|
descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do
|
||||||
E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId
|
E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId
|
||||||
@ -116,8 +116,8 @@ getAdminWorkflowDefinitionListR = do
|
|||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
|
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
|
||||||
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
|
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
|
||||||
, singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
, singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
||||||
, singletonMap "instance-title" . FilterProjected $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
, singletonMap "instance-title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
||||||
]
|
]
|
||||||
dbtFilterUI mPrev = mconcat
|
dbtFilterUI mPrev = mconcat
|
||||||
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName)
|
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName)
|
||||||
|
|||||||
@ -75,11 +75,8 @@ getAdminWorkflowInstanceListR = do
|
|||||||
|
|
||||||
return (workflowInstance, workflowCount)
|
return (workflowInstance, workflowCount)
|
||||||
dbtRowKey = (E.^. WorkflowInstanceId)
|
dbtRowKey = (E.^. WorkflowInstanceId)
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
dbtProj = dbtProjFilteredPostSimple $ \(wi@(Entity wiId _), E.Value iCount) ->
|
||||||
wi@(Entity wiId _) <- view _1
|
(wi, , iCount) <$> selectWorkflowInstanceDescription wiId
|
||||||
desc <- lift $ selectWorkflowInstanceDescription wiId
|
|
||||||
(wi, desc,)
|
|
||||||
<$> view (_2 . _Value)
|
|
||||||
dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
|
dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
[ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) . anchorEdit $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18n
|
[ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) . anchorEdit $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18n
|
||||||
@ -105,7 +102,7 @@ getAdminWorkflowInstanceListR = do
|
|||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowInstanceName)
|
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowInstanceName)
|
||||||
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowInstanceScope)
|
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowInstanceScope)
|
||||||
, singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
, singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
||||||
]
|
]
|
||||||
dbtFilterUI mPrev = mconcat
|
dbtFilterUI mPrev = mconcat
|
||||||
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowInstanceName)
|
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowInstanceName)
|
||||||
|
|||||||
@ -41,6 +41,24 @@ import qualified Control.Monad.State.Class as State
|
|||||||
import qualified Data.RFC5051 as RFC5051
|
import qualified Data.RFC5051 as RFC5051
|
||||||
|
|
||||||
|
|
||||||
|
data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj
|
||||||
|
{ wwProjFilterMayAccess :: Maybe Bool
|
||||||
|
, wwProjFilterWorkflowWorkflow :: Maybe [[CI Char]]
|
||||||
|
, wwProjFilterCurrentState :: Maybe [[CI Char]]
|
||||||
|
, wwProjFilterFinal :: Maybe Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Default WorkflowWorkflowListFilterProj where
|
||||||
|
def = WorkflowWorkflowListFilterProj
|
||||||
|
{ wwProjFilterMayAccess = Nothing
|
||||||
|
, wwProjFilterWorkflowWorkflow = Nothing
|
||||||
|
, wwProjFilterCurrentState = Nothing
|
||||||
|
, wwProjFilterFinal = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
|
makeLenses_ ''WorkflowWorkflowListFilterProj
|
||||||
|
|
||||||
|
|
||||||
getGlobalWorkflowWorkflowListR :: Handler Html
|
getGlobalWorkflowWorkflowListR :: Handler Html
|
||||||
getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
|
getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
|
||||||
|
|
||||||
@ -231,15 +249,24 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
|||||||
lift <=< asks $ E.where_ . sqlPred
|
lift <=< asks $ E.where_ . sqlPred
|
||||||
return (workflowWorkflow, workflowInstance)
|
return (workflowWorkflow, workflowInstance)
|
||||||
dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
|
dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
|
||||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
|
||||||
ww@(Entity wwId WorkflowWorkflow{..}) <- view _1
|
ww@(Entity wwId WorkflowWorkflow{..}) <- view $ _dbtProjRow . _dbrOutput . _1
|
||||||
mwi <- view _2
|
mwi <- view $ _dbtProjRow . _dbrOutput . _2
|
||||||
wiDesc <- lift . runMaybeT $ do
|
|
||||||
|
cID <- encrypt wwId
|
||||||
|
forMM_ (view $ _dbtProjFilter . _wwProjFilterWorkflowWorkflow) $ \criteria ->
|
||||||
|
let haystack = map CI.mk . unpack $ toPathPiece cID
|
||||||
|
in guard $ any (`isInfixOf` haystack) criteria
|
||||||
|
|
||||||
|
rScope <- lift . lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||||
|
forMM_ (view $ _dbtProjFilter . _wwProjFilterMayAccess) $ \needle -> do
|
||||||
|
rScope' <- hoistMaybe rScope
|
||||||
|
guardM . lift . lift $ (== needle) . is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)) False
|
||||||
|
|
||||||
|
wiDesc <- lift . lift . $cachedHereBinary (entityKey <$> mwi) . runMaybeT $ do
|
||||||
Entity wiId _ <- hoistMaybe mwi
|
Entity wiId _ <- hoistMaybe mwi
|
||||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||||
cID <- encrypt wwId
|
WorkflowGraph{..} <- lift . lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
|
||||||
rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
|
||||||
WorkflowGraph{..} <- lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
|
|
||||||
let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
|
let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
|
||||||
hasWorkflowRole' role = maybeT (return False) $ do
|
hasWorkflowRole' role = maybeT (return False) $ do
|
||||||
rScope' <- hoistMaybe rScope
|
rScope' <- hoistMaybe rScope
|
||||||
@ -247,7 +274,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
|||||||
lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
||||||
|
|
||||||
let
|
let
|
||||||
goAction p w = lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
|
goAction p w = lift . lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
|
||||||
where
|
where
|
||||||
go Nothing = return Nothing
|
go Nothing = return Nothing
|
||||||
go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do
|
go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do
|
||||||
@ -264,7 +291,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
|||||||
| otherwise -> maybeT (return WHIAHidden) $ do
|
| otherwise -> maybeT (return WHIAHidden) $ do
|
||||||
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
||||||
guardM . lift $ anyM (otoList viewActors) hasWorkflowRole'
|
guardM . lift $ anyM (otoList viewActors) hasWorkflowRole'
|
||||||
resUser <- lift $ traverse getEntity wpUser'
|
resUser <- lift . for wpUser' $ \uid -> $cachedHereBinary uid $ getEntity uid
|
||||||
return $ case resUser of
|
return $ case resUser of
|
||||||
Nothing -> WHIAOther Nothing
|
Nothing -> WHIAOther Nothing
|
||||||
Just Nothing -> WHIAGone
|
Just Nothing -> WHIAGone
|
||||||
@ -280,7 +307,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
|||||||
<*> pure actFinal
|
<*> pure actFinal
|
||||||
lastAct <- descAction $ re _nullable . _Snoc . swapped
|
lastAct <- descAction $ re _nullable . _Snoc . swapped
|
||||||
|
|
||||||
persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do
|
persons' <- lift . lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do
|
||||||
let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes
|
let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes
|
||||||
guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act
|
guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act
|
||||||
lift . maybeT_ . hoist (zoom _1) $ do
|
lift . maybeT_ . hoist (zoom _1) $ do
|
||||||
@ -296,12 +323,12 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
|||||||
guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole'
|
guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole'
|
||||||
at pLbl ?= users
|
at pLbl ?= users
|
||||||
|
|
||||||
persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons'
|
persons <- lift . lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons'
|
||||||
|
|
||||||
return (cID, rScope, ww, mwi, wiDesc, lastAct, persons)
|
return (cID, rScope, ww, mwi, wiDesc, lastAct, persons)
|
||||||
dbtColonnade :: Colonnade Sortable _ _
|
dbtColonnade :: Colonnade Sortable _ _
|
||||||
dbtColonnade = mconcat -- TODO: columns
|
dbtColonnade = mconcat -- TODO: columns
|
||||||
[ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . toPathPiece
|
[ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . (toPathPiece :: CryptoFileNameWorkflowWorkflow -> Text)
|
||||||
, guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x
|
, guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x
|
||||||
, guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x
|
, guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x
|
||||||
, sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x ->
|
, sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x ->
|
||||||
@ -352,23 +379,37 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
|||||||
, singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just)
|
, singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just)
|
||||||
]
|
]
|
||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
|
[ singletonMap "workflow-workflow" . FilterProjected $ \(criteria :: Set Text) ->
|
||||||
let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
|
|
||||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
|
||||||
in any (`isInfixOf` cid) criteria'
|
|
||||||
, singletonMap "may-access" . FilterProjected $ \x (Any b) -> fmap (== b) . maybeT (return False) $ do
|
|
||||||
let cID = x ^. resultWorkflowWorkflowId
|
|
||||||
rScope <- hoistMaybe $ x ^. resultRouteScope
|
|
||||||
lift . lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
|
|
||||||
, singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
|
|
||||||
let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||||
in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
|
in _wwProjFilterWorkflowWorkflow ?~ criteria'
|
||||||
, singletonMap "final" . FilterProjected $ \x (criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of
|
, singletonMap "current-state" . FilterProjected $ \(criteria :: Set Text) -> -- TODO
|
||||||
Nothing -> True
|
let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||||
Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
|
in _wwProjFilterCurrentState ?~ criteria'
|
||||||
&& has (resultLastAction . _Just . actionFinal . _Just) x
|
, singletonMap "final" . FilterProjected $ \(criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of -- TODO
|
||||||
in needle == val
|
Nothing -> id
|
||||||
|
Just needle -> _wwProjFilterFinal ?~ needle
|
||||||
|
, singletonMap "may-access" . FilterProjected $ \(Any criterion) -> _wwProjFilterMayAccess ?~ criterion
|
||||||
]
|
]
|
||||||
|
-- [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
|
||||||
|
-- let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
|
||||||
|
-- criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||||
|
-- in any (`isInfixOf` cid) criteria'
|
||||||
|
-- ,
|
||||||
|
|
||||||
|
-- , singletonMap "may-access" . FilterPreProjected $ \(x :: DBRow (Entity WorkflowWorkflow, Maybe (Entity WorkflowInstance))) (Any b) -> fmap (== b) . maybeT (return False) $ do
|
||||||
|
-- let Entity wwId WorkflowWorkflow{..} = x ^. _dbrOutput . _1
|
||||||
|
-- cID <- encrypt wwId
|
||||||
|
-- rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||||
|
-- lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
|
||||||
|
-- , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
|
||||||
|
-- let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||||
|
-- in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
|
||||||
|
-- , singletonMap "final" . FilterProjected $ \x (criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of
|
||||||
|
-- Nothing -> True
|
||||||
|
-- Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
|
||||||
|
-- && has (resultLastAction . _Just . actionFinal . _Just) x
|
||||||
|
-- in needle == val
|
||||||
|
-- ]
|
||||||
dbtFilterUI = mconcat
|
dbtFilterUI = mconcat
|
||||||
[ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber)
|
[ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber)
|
||||||
, flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState)
|
, flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState)
|
||||||
|
|||||||
@ -363,15 +363,15 @@ derivePersistField "CorrectorState"
|
|||||||
showCompactCorrectorLoad :: Load -> CorrectorState -> Text
|
showCompactCorrectorLoad :: Load -> CorrectorState -> Text
|
||||||
showCompactCorrectorLoad load CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]"
|
showCompactCorrectorLoad load CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]"
|
||||||
showCompactCorrectorLoad load CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}"
|
showCompactCorrectorLoad load CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}"
|
||||||
showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = tutorialText
|
showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = fromMaybe mempty tutorialText
|
||||||
| otherwise = proportionText <> " + " <> tutorialText
|
| otherwise = maybe id (\tt pt -> pt <> " + " <> tt) tutorialText proportionText
|
||||||
where
|
where
|
||||||
proportionText = let propDbl :: Double
|
proportionText = let propDbl :: Double
|
||||||
propDbl = fromRational byProportion
|
propDbl = fromRational byProportion
|
||||||
in tshow $ roundToDigits 2 propDbl
|
in tshow $ roundToDigits 2 propDbl
|
||||||
tutorialText = case byTutorial of Nothing -> mempty
|
tutorialText = byTutorial <&> \case
|
||||||
Just True -> "(T)"
|
True -> "(T)"
|
||||||
Just False -> "T"
|
False -> "T"
|
||||||
|
|
||||||
instance Csv.ToField (SheetType epid, Maybe Points) where
|
instance Csv.ToField (SheetType epid, Maybe Points) where
|
||||||
toField (_, Nothing) = mempty
|
toField (_, Nothing) = mempty
|
||||||
|
|||||||
@ -67,6 +67,8 @@ import Data.List (inits)
|
|||||||
|
|
||||||
import Data.RFC5051 (compareUnicode)
|
import Data.RFC5051 (compareUnicode)
|
||||||
|
|
||||||
|
import qualified Data.Binary as Binary
|
||||||
|
|
||||||
|
|
||||||
----- WORKFLOW GRAPH -----
|
----- WORKFLOW GRAPH -----
|
||||||
|
|
||||||
@ -474,7 +476,7 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work
|
|||||||
(WFPBool{}, _) -> LT
|
(WFPBool{}, _) -> LT
|
||||||
(WFPDay{}, WFPText{}) -> GT
|
(WFPDay{}, WFPText{}) -> GT
|
||||||
(WFPDay{}, WFPNumber{}) -> GT
|
(WFPDay{}, WFPNumber{}) -> GT
|
||||||
(WFPDay{}, WFPDay{}) -> GT
|
(WFPDay{}, WFPBool{}) -> GT
|
||||||
(WFPDay{}, _) -> LT
|
(WFPDay{}, _) -> LT
|
||||||
(WFPFile{}, WFPText{}) -> GT
|
(WFPFile{}, WFPText{}) -> GT
|
||||||
(WFPFile{}, WFPNumber{}) -> GT
|
(WFPFile{}, WFPNumber{}) -> GT
|
||||||
@ -488,6 +490,7 @@ workflowPayloadSort
|
|||||||
(fileid -> fileid -> Ordering)
|
(fileid -> fileid -> Ordering)
|
||||||
-> (userid -> userid -> Ordering)
|
-> (userid -> userid -> Ordering)
|
||||||
-> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering)
|
-> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering)
|
||||||
|
-- ^ @workflowPayloadSort compare compare /= compare@
|
||||||
workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
|
workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
|
||||||
(WFPText a', WFPText b' ) -> compareUnicode a' b'
|
(WFPText a', WFPText b' ) -> compareUnicode a' b'
|
||||||
(WFPText{}, _ ) -> LT
|
(WFPText{}, _ ) -> LT
|
||||||
@ -545,7 +548,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW
|
|||||||
|
|
||||||
data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
|
data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
|
||||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
|
deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
|
||||||
deriving anyclass (Universe, Finite, NFData)
|
deriving anyclass (Universe, Finite, NFData, Binary)
|
||||||
|
|
||||||
type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload
|
type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload
|
||||||
|
|
||||||
@ -1127,6 +1130,24 @@ instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowSc
|
|||||||
|
|
||||||
instance Binary userid => Binary (WorkflowRole userid)
|
instance Binary userid => Binary (WorkflowRole userid)
|
||||||
|
|
||||||
|
instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowAction fileid userid)
|
||||||
|
instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowFieldPayloadW fileid userid) where
|
||||||
|
get = Binary.get >>= \case
|
||||||
|
WFPText' -> WorkflowFieldPayloadW . WFPText <$> Binary.get
|
||||||
|
WFPNumber' -> WorkflowFieldPayloadW . WFPNumber <$> Binary.get
|
||||||
|
WFPBool' -> WorkflowFieldPayloadW . WFPBool <$> Binary.get
|
||||||
|
WFPDay' -> WorkflowFieldPayloadW . WFPDay <$> Binary.get
|
||||||
|
WFPFile' -> WorkflowFieldPayloadW . WFPFile <$> Binary.get
|
||||||
|
WFPUser' -> WorkflowFieldPayloadW . WFPUser <$> Binary.get
|
||||||
|
put = \case
|
||||||
|
WorkflowFieldPayloadW (WFPText t ) -> Binary.put WFPText' >> Binary.put t
|
||||||
|
WorkflowFieldPayloadW (WFPNumber n ) -> Binary.put WFPNumber' >> Binary.put n
|
||||||
|
WorkflowFieldPayloadW (WFPBool b ) -> Binary.put WFPBool' >> Binary.put b
|
||||||
|
WorkflowFieldPayloadW (WFPDay d ) -> Binary.put WFPDay' >> Binary.put d
|
||||||
|
WorkflowFieldPayloadW (WFPFile fid) -> Binary.put WFPFile' >> Binary.put fid
|
||||||
|
WorkflowFieldPayloadW (WFPUser uid) -> Binary.put WFPUser' >> Binary.put uid
|
||||||
|
|
||||||
|
|
||||||
----- TH Jail -----
|
----- TH Jail -----
|
||||||
|
|
||||||
makeWrapped ''WorkflowGraphReference
|
makeWrapped ''WorkflowGraphReference
|
||||||
|
|||||||
15
src/Utils.hs
15
src/Utils.hs
@ -7,6 +7,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)
|
|||||||
|
|
||||||
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
|
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
|
||||||
import qualified Data.Foldable as Fold
|
import qualified Data.Foldable as Fold
|
||||||
|
import qualified Data.Traversable as Trav
|
||||||
import Data.Foldable as Utils (foldlM, foldrM)
|
import Data.Foldable as Utils (foldlM, foldrM)
|
||||||
import Data.Monoid (First, Sum(..), Endo)
|
import Data.Monoid (First, Sum(..), Endo)
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
@ -975,6 +976,20 @@ sortOnM :: (Ord b, Monad m)
|
|||||||
-> m [a]
|
-> m [a]
|
||||||
sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x)
|
sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x)
|
||||||
|
|
||||||
|
-- Stolen from Agda...
|
||||||
|
|
||||||
|
mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b)
|
||||||
|
mapMM f mxs = Trav.mapM f =<< mxs
|
||||||
|
|
||||||
|
forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b)
|
||||||
|
forMM = flip mapMM
|
||||||
|
|
||||||
|
mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m ()
|
||||||
|
mapMM_ f mxs = Fold.mapM_ f =<< mxs
|
||||||
|
|
||||||
|
forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m ()
|
||||||
|
forMM_ = flip mapMM_
|
||||||
|
|
||||||
--------------
|
--------------
|
||||||
-- Foldable --
|
-- Foldable --
|
||||||
--------------
|
--------------
|
||||||
|
|||||||
@ -12,9 +12,12 @@ module Utils.Workflow
|
|||||||
, selectWorkflowInstanceDescription
|
, selectWorkflowInstanceDescription
|
||||||
, SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
|
, SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
|
||||||
, insertSharedWorkflowGraph
|
, insertSharedWorkflowGraph
|
||||||
|
, getWorkflowWorkflowState', getWorkflowWorkflowState
|
||||||
|
, WorkflowWorkflowStateParseException(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoFoundation
|
import Import.NoFoundation
|
||||||
|
import Foundation.Type
|
||||||
|
|
||||||
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
||||||
import qualified Crypto.MAC.KMAC as Crypto
|
import qualified Crypto.MAC.KMAC as Crypto
|
||||||
@ -25,8 +28,11 @@ import qualified Crypto.Hash as Crypto
|
|||||||
import Language.Haskell.TH (nameBase)
|
import Language.Haskell.TH (nameBase)
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
|
|
||||||
|
import Handler.Utils.Memcached
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
import qualified Database.Esqueleto.Utils as E
|
import qualified Database.Esqueleto.Utils as E
|
||||||
|
import qualified Database.Esqueleto.Internal.Internal as E
|
||||||
|
|
||||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||||
|
|
||||||
@ -49,19 +55,19 @@ _DBWorkflowScope = iso toScope' toScope
|
|||||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey
|
||||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey)
|
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey)
|
||||||
|
|
||||||
fromRouteWorkflowScope :: ( MonadIO m
|
fromRouteWorkflowScope :: ( MonadHandler m
|
||||||
, BackendCompatible SqlReadBackend backend
|
, BackendCompatible SqlReadBackend backend
|
||||||
)
|
)
|
||||||
=> RouteWorkflowScope
|
=> RouteWorkflowScope
|
||||||
-> MaybeT (ReaderT backend m) IdWorkflowScope
|
-> MaybeT (ReaderT backend m) IdWorkflowScope
|
||||||
fromRouteWorkflowScope rScope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
fromRouteWorkflowScope rScope = $cachedHereBinary rScope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||||
|
|
||||||
toRouteWorkflowScope :: ( MonadIO m
|
toRouteWorkflowScope :: ( MonadHandler m
|
||||||
, BackendCompatible SqlReadBackend backend
|
, BackendCompatible SqlReadBackend backend
|
||||||
)
|
)
|
||||||
=> IdWorkflowScope
|
=> IdWorkflowScope
|
||||||
-> MaybeT (ReaderT backend m) RouteWorkflowScope
|
-> MaybeT (ReaderT backend m) RouteWorkflowScope
|
||||||
toRouteWorkflowScope scope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
|
toRouteWorkflowScope scope = $cachedHereBinary scope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
|
||||||
|
|
||||||
|
|
||||||
type IdWorkflowGraph = WorkflowGraph FileReference UserId
|
type IdWorkflowGraph = WorkflowGraph FileReference UserId
|
||||||
@ -168,3 +174,51 @@ insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
|
|||||||
where
|
where
|
||||||
swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
|
swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
|
||||||
swgId' = SharedWorkflowGraphKey swgId
|
swgId' = SharedWorkflowGraphKey swgId
|
||||||
|
|
||||||
|
|
||||||
|
newtype WorkflowWorkflowStateParse = WorkflowWorkflowStateParse PersistValue
|
||||||
|
deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
|
||||||
|
deriving anyclass (Binary)
|
||||||
|
|
||||||
|
newtype WorkflowWorkflowStateParseException = WorkflowWorkflowStateParseException Text
|
||||||
|
deriving stock (Show, Generic, Typeable)
|
||||||
|
deriving anyclass (Exception)
|
||||||
|
|
||||||
|
getWorkflowWorkflowState' :: forall backend m.
|
||||||
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
|
, BackendCompatible SqlReadBackend backend
|
||||||
|
, MonadThrow m
|
||||||
|
)
|
||||||
|
=> WorkflowWorkflowId
|
||||||
|
-> Maybe WorkflowWorkflow
|
||||||
|
-> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
|
||||||
|
getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend . projectBackend @SqlReadBackend) . runMaybeT $ do
|
||||||
|
res <- MaybeT . E.selectMaybe . E.from $ \workflowWorkflow -> do
|
||||||
|
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowId E.==. E.val wwId
|
||||||
|
return
|
||||||
|
( workflowWorkflow E.^. WorkflowWorkflowInstance
|
||||||
|
, workflowWorkflow E.^. WorkflowWorkflowScope
|
||||||
|
, workflowWorkflow E.^. WorkflowWorkflowGraph
|
||||||
|
, E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState
|
||||||
|
)
|
||||||
|
let
|
||||||
|
( E.Value workflowWorkflowInstance
|
||||||
|
, E.Value workflowWorkflowScope
|
||||||
|
, E.Value workflowWorkflowGraph
|
||||||
|
, E.Value (wwState :: PersistValue) -- Don't parse
|
||||||
|
) = res
|
||||||
|
wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState
|
||||||
|
case wwState' of
|
||||||
|
Left err -> lift . throwM $ WorkflowWorkflowStateParseException err
|
||||||
|
Right workflowWorkflowState -> return $ Entity wwId WorkflowWorkflow{..}
|
||||||
|
getWorkflowWorkflowState' wwId (Just ww@WorkflowWorkflow{..}) = Just (Entity wwId ww) <$ do
|
||||||
|
memcachedBySet Nothing (WorkflowWorkflowStateParse $ toPersistValue workflowWorkflowState) workflowWorkflowState
|
||||||
|
|
||||||
|
getWorkflowWorkflowState :: forall backend m.
|
||||||
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
|
, BackendCompatible SqlReadBackend backend
|
||||||
|
, MonadThrow m
|
||||||
|
)
|
||||||
|
=> WorkflowWorkflowId
|
||||||
|
-> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
|
||||||
|
getWorkflowWorkflowState = flip getWorkflowWorkflowState' Nothing
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{ ghc, nixpkgs ? import ./nixpkgs.nix {} }:
|
{ ghc, nixpkgs ? import ./nixpkgs.nix }:
|
||||||
|
|
||||||
let
|
let
|
||||||
# haskellPackages = import ./stackage.nix { inherit nixpkgs; };
|
# haskellPackages = import ./stackage.nix { inherit nixpkgs; };
|
||||||
|
|||||||
@ -24,7 +24,7 @@ extra-deps:
|
|||||||
commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
|
commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
|
||||||
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/conduit-resumablesink.git
|
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/conduit-resumablesink.git
|
||||||
commit: cbea6159c2975d42f948525e03e12fc390da53c5
|
commit: cbea6159c2975d42f948525e03e12fc390da53c5
|
||||||
- git: git://github.com/jtdaugherty/HaskellNet.git
|
- git: https://github.com/jtdaugherty/HaskellNet.git
|
||||||
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
|
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
|
||||||
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/HaskellNet-SSL.git
|
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/HaskellNet-SSL.git
|
||||||
commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
|
commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
|
||||||
|
|||||||
@ -40,13 +40,13 @@ packages:
|
|||||||
- completed:
|
- completed:
|
||||||
name: HaskellNet
|
name: HaskellNet
|
||||||
version: 0.5.1
|
version: 0.5.1
|
||||||
git: git://github.com/jtdaugherty/HaskellNet.git
|
git: https://github.com/jtdaugherty/HaskellNet.git
|
||||||
pantry-tree:
|
pantry-tree:
|
||||||
size: 4011
|
size: 4011
|
||||||
sha256: 921b437ef18ccb04f889301c407263d6b5b72c5864803a000b1e61328988ce70
|
sha256: 921b437ef18ccb04f889301c407263d6b5b72c5864803a000b1e61328988ce70
|
||||||
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
|
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
|
||||||
original:
|
original:
|
||||||
git: git://github.com/jtdaugherty/HaskellNet.git
|
git: https://github.com/jtdaugherty/HaskellNet.git
|
||||||
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
|
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
|
||||||
- completed:
|
- completed:
|
||||||
name: HaskellNet-SSL
|
name: HaskellNet-SSL
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{ nixpkgs ? import ./nixpkgs.nix {}
|
{ nixpkgs ? import ./nixpkgs.nix
|
||||||
, snapshot ? "lts-13.21"
|
, snapshot ? "lts-13.21"
|
||||||
}:
|
}:
|
||||||
|
|
||||||
|
|||||||
5
start.sh
5
start.sh
@ -16,6 +16,7 @@ export COOKIES_SECURE=${COOKIES_SECURE:-false}
|
|||||||
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||||
export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
|
export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
|
||||||
export RIBBON=${RIBBON:-${__HOST:-localhost}}
|
export RIBBON=${RIBBON:-${__HOST:-localhost}}
|
||||||
|
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
|
||||||
unset HOST
|
unset HOST
|
||||||
|
|
||||||
move-back() {
|
move-back() {
|
||||||
@ -31,10 +32,10 @@ fi
|
|||||||
|
|
||||||
if ! [ -z "$(which yesod)" ]
|
if ! [ -z "$(which yesod)" ]
|
||||||
then
|
then
|
||||||
yesod devel $@
|
yesod devel -p $((${PORT_OFFSET:-0} + 3000)) -q $((${PORT_OFFSET:-0} + 3443)) $@
|
||||||
elif ! [ -z "$(which stack)" ]
|
elif ! [ -z "$(which stack)" ]
|
||||||
then
|
then
|
||||||
stack exec -- yesod devel $@
|
stack exec -- yesod devel -p $((${PORT_OFFSET:-0} + 3000)) -q $((${PORT_OFFSET:-0} + 3443)) $@
|
||||||
else
|
else
|
||||||
exit 1
|
exit 1
|
||||||
fi
|
fi
|
||||||
|
|||||||
15
templates/i18n/help-instructions/de-de-formal.hamlet
Normal file
15
templates/i18n/help-instructions/de-de-formal.hamlet
Normal file
@ -0,0 +1,15 @@
|
|||||||
|
$newline never
|
||||||
|
|
||||||
|
<p>
|
||||||
|
|
||||||
|
Bitte bedenken Sie beim Stellen Ihrer Anfrage, dass das #
|
||||||
|
Uni2work-Kernteam aktuell aus Sarah Vaupel und Gregor Kleen besteht #
|
||||||
|
und zwei Personen nicht hinreichend sind um in allen Fällen eine #
|
||||||
|
zeitnahe Bearbeitung Ihres Anliegens zu garantieren.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
|
||||||
|
Falls sich Ihr Anliegen auf eine konkrete Veranstaltung bezieht, #
|
||||||
|
ziehen Sie bitte auch in Betracht (insbesondere bei zeitkritischen #
|
||||||
|
Anliegen wie z.B. Abgaben) sich direkt an die Kursverwalter zu #
|
||||||
|
wenden.
|
||||||
15
templates/i18n/help-instructions/en-eu.hamlet
Normal file
15
templates/i18n/help-instructions/en-eu.hamlet
Normal file
@ -0,0 +1,15 @@
|
|||||||
|
$newline never
|
||||||
|
|
||||||
|
<p>
|
||||||
|
|
||||||
|
When formulating your request please consider that the Uni2work core #
|
||||||
|
team currently consists of Sarah Vaupel and Gregor Kleen and that #
|
||||||
|
two people are not enough to guarantee a timely answer in all cases.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
|
||||||
|
If your request is related to a specific course, please also #
|
||||||
|
consider contacting the relevant course administrators as well. #
|
||||||
|
|
||||||
|
Especially if your request is time sensitive (e.g. submitting for an #
|
||||||
|
exercise sheet).
|
||||||
@ -3,11 +3,12 @@ $newline never
|
|||||||
|
|
||||||
<h4>Inhalt
|
<h4>Inhalt
|
||||||
<ul style="list-style-type: none">
|
<ul style="list-style-type: none">
|
||||||
<li>Gregor Kleen
|
<li>Gregor Kleen & Sarah Vaupel
|
||||||
<li>Oettingenstraße 67
|
<li>Oettingenstraße 67
|
||||||
<li>D-80538 München
|
<li>D-80538 München
|
||||||
<li>E-Mail: ^{mailtoHtml "gregor.kleen@tcs.ifi.lmu.de"}
|
<li>E-Mail: ^{mailtoHtml "uni2work@ifi.lmu.de"}
|
||||||
<li>Telefon: +49 (0) 89 / 2180 - 9139
|
<li>Telefon (Gregor Kleen): +49 (0) 89 / 2180 - 9139
|
||||||
|
<li>Telefon (Sarah Vaupel): —
|
||||||
|
|
||||||
<h4>Jugendschutz
|
<h4>Jugendschutz
|
||||||
<ul style="list-style-type: none">
|
<ul style="list-style-type: none">
|
||||||
|
|||||||
@ -3,11 +3,12 @@ $newline never
|
|||||||
|
|
||||||
<h4>Contents
|
<h4>Contents
|
||||||
<ul style="list-style-type: none">
|
<ul style="list-style-type: none">
|
||||||
<li>Gregor Kleen
|
<li>Gregor Kleen & Sarah Vaupel
|
||||||
<li>Oettingenstraße 67
|
<li>Oettingenstraße 67
|
||||||
<li>D-80538 München (Germany)
|
<li>D-80538 München (Germany)
|
||||||
<li>E-Mail: ^{mailtoHtml "gregor.kleen@tcs.ifi.lmu.de"}
|
<li>E-Mail: ^{mailtoHtml "uni2work@ifi.lmu.de"}
|
||||||
<li>Telefon: +49 (0) 89 / 2180 - 9139
|
<li>Telefon (Gregor Kleen): +49 (0) 89 / 2180 - 9139
|
||||||
|
<li>Telefon (Sarah Vaupel): —
|
||||||
|
|
||||||
<h4>Youth Protection
|
<h4>Youth Protection
|
||||||
<ul style="list-style-type: none">
|
<ul style="list-style-type: none">
|
||||||
|
|||||||
@ -160,3 +160,5 @@ spec = do
|
|||||||
[ eqLaws, ordLaws, jsonLaws ]
|
[ eqLaws, ordLaws, jsonLaws ]
|
||||||
lawsCheckHspec (Proxy @WorkflowScope')
|
lawsCheckHspec (Proxy @WorkflowScope')
|
||||||
[ eqLaws, ordLaws, boundedEnumLaws, showLaws, showReadLaws, universeLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
|
[ eqLaws, ordLaws, boundedEnumLaws, showLaws, showReadLaws, universeLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
|
||||||
|
lawsCheckHspec (Proxy @(WorkflowFieldPayloadW FileReference SqlBackendKey))
|
||||||
|
[ eqLaws, ordLaws, showLaws, jsonLaws, binaryLaws ]
|
||||||
|
|||||||
@ -523,6 +523,16 @@ spec = do
|
|||||||
toPathPiece ExamCloseSeparate `shouldBe` "separate"
|
toPathPiece ExamCloseSeparate `shouldBe` "separate"
|
||||||
toPathPiece (ExamCloseOnFinished False) `shouldBe` "on-finished"
|
toPathPiece (ExamCloseOnFinished False) `shouldBe` "on-finished"
|
||||||
toPathPiece (ExamCloseOnFinished True) `shouldBe` "on-finished-hidden"
|
toPathPiece (ExamCloseOnFinished True) `shouldBe` "on-finished-hidden"
|
||||||
|
describe "CompactCorrectorLoad" $ do
|
||||||
|
it "matches expectations" . example $ do
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0 } CorrectorNormal `shouldBe` "T"
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 0 } CorrectorNormal `shouldBe` "(T)"
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorNormal `shouldBe` "1.0"
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1 } CorrectorNormal `shouldBe` "1.0 + T"
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 1 } CorrectorNormal `shouldBe` "1.0 + (T)"
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0 } CorrectorNormal `shouldBe` ""
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorMissing `shouldBe` "[1.0]"
|
||||||
|
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorExcused `shouldBe` "{1.0}"
|
||||||
|
|
||||||
termExample :: (TermIdentifier, Text) -> Expectation
|
termExample :: (TermIdentifier, Text) -> Expectation
|
||||||
termExample (term, encoded) = example $ do
|
termExample (term, encoded) = example $ do
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user