Compare commits
8 Commits
master
...
build/imag
| Author | SHA1 | Date | |
|---|---|---|---|
| 8303e91a4a | |||
| 84cb3842c0 | |||
| 7ce4ed5fe0 | |||
| 13e708d353 | |||
| ae7c3d25a9 | |||
| 763fa702da | |||
| e0fc837115 | |||
|
|
167453048e |
@ -1,65 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: releaseTag
|
||||
type: string
|
||||
- name: releaseEndpoint
|
||||
type: string
|
||||
default: 'devfra'
|
||||
values:
|
||||
- 'devfra'
|
||||
- 'prodfra'
|
||||
|
||||
jobs:
|
||||
- job: Release
|
||||
displayName: Release ${{ parameters.releaseTag }}
|
||||
container:
|
||||
image: devfra.azurecr.io/de.fraport.build/tools:1.1.0
|
||||
endpoint: devfra
|
||||
steps:
|
||||
|
||||
# Download required artifacts from pipeline
|
||||
- task: DownloadPipelineArtifact@2
|
||||
displayName: Download FraDrive binaries
|
||||
inputs:
|
||||
artifactName: Build_backend
|
||||
patterns: 'Build_backend/bin/*'
|
||||
targetPath: '$(Build.Repository.LocalPath)'
|
||||
|
||||
- task: Docker@2
|
||||
displayName: Login to container registry
|
||||
inputs:
|
||||
command: login
|
||||
containerRegistry: '${{ parameters.releaseEndpoint }}'
|
||||
- task: Bash@3
|
||||
displayName: Build FraDrive container
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
cp docker/fradrive/Dockerfile .
|
||||
docker build \
|
||||
--tag $(buildImageUpstream)/fradrive:$(Build.BuildNumber) \
|
||||
--tag $(buildImageUpstream)/fradrive:${{parameters.releaseTag}} \
|
||||
--build-arg FROM_IMG=devfra.azurecr.io/de.fraport.trusted/ubuntu \
|
||||
--build-arg FROM_TAG=20.04 \
|
||||
--build-arg PROJECT_DIR=$(Build.Repository.LocalPath) \
|
||||
--build-arg IN_CI=true \
|
||||
--build-arg IN_CONTAINER=true \
|
||||
--build-arg HTTPS_PROXY=http://proxy.frankfurt-airport.de:8080 \
|
||||
--build-arg HTTP_PROXY=http://proxy.frankfurt-airport.de:8080 \
|
||||
--build-arg NO_PROXY='localhost,127.0.0.1,*.docker.internal,*.azmk8s.io,devfra.azurecr.io,devfra.westeurope.data.azurecr.io' \
|
||||
--build-arg FRAPORT_NOPROXY=dev.azure.com,*.dev.azure.com,*.fraport.de,*.frankfurt-airport.de \
|
||||
.
|
||||
- task: Docker@2
|
||||
displayName: Push container to registry
|
||||
inputs:
|
||||
command: push
|
||||
repository: 'de.fraport.fradrive.build/fradrive'
|
||||
tags: '$(Build.BuildNumber),${{parameters.releaseTag}}'
|
||||
- task: Docker@2
|
||||
displayName: Logout from container registry
|
||||
inputs:
|
||||
command: logout
|
||||
containerRegistry: '${{ parameters.releaseEndpoint }}'
|
||||
@ -1,61 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2024-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: serviceName
|
||||
type: string
|
||||
- name: dependenciesCaches
|
||||
type: object
|
||||
default: []
|
||||
- name: dependenciesBuildPool
|
||||
type: string
|
||||
default: 'Prod Private Agent Pool'
|
||||
values:
|
||||
- 'Prod Private Agent Pool'
|
||||
- 'Prod Private Agent Pool DS2'
|
||||
- 'Prod Private Agent Pool DS3'
|
||||
- name: dependenciesBuildCores
|
||||
type: number
|
||||
default: 1
|
||||
- name: dependenciesBuildTimeout
|
||||
type: number
|
||||
default: 60
|
||||
|
||||
jobs:
|
||||
- job: SetupDependencies_${{parameters.serviceName}}
|
||||
displayName: Install ${{parameters.serviceName}} dependencies
|
||||
dependsOn: SetupImage_${{parameters.serviceName}}
|
||||
${{ if eq(variables.setupImages, true) }}:
|
||||
condition: succeeded()
|
||||
${{ else }}:
|
||||
condition: always()
|
||||
pool: '${{parameters.dependenciesBuildPool}}'
|
||||
timeoutInMinutes: ${{parameters.dependenciesBuildTimeout}}
|
||||
container:
|
||||
${{ if variables.setupImages }}:
|
||||
image: $(buildImageUpstream)/${{parameters.serviceName}}:$(Build.BuildNumber)
|
||||
${{ else }}:
|
||||
image: $(buildImageUpstream)/${{parameters.serviceName}}:latest
|
||||
endpoint: devfra
|
||||
env:
|
||||
PROJECT_DIR: $(Build.Repository.LocalPath)
|
||||
IN_CONTAINER: true
|
||||
IN_CI: true
|
||||
steps:
|
||||
# Restore previously-built dependencies from caches
|
||||
- ${{ each cache in parameters.dependenciesCaches }}:
|
||||
- template: ./../../steps/cache.yaml
|
||||
parameters:
|
||||
cacheIdent: '${{parameters.serviceName}}-dependencies'
|
||||
cacheKeys: '${{cache.key}}'
|
||||
cachePath: '${{cache.path}}'
|
||||
|
||||
# Compile dependencies
|
||||
- template: ./../../steps/make.yaml
|
||||
parameters:
|
||||
makeJob: dependencies
|
||||
makeService: ${{parameters.serviceName}}
|
||||
makeVars: 'CPU_CORES=${{parameters.dependenciesBuildCores}} STACK_CORES=-j${{parameters.dependenciesBuildCores}}'
|
||||
|
||||
# (Note: a post-job for updating the dependency cache is automatically created, so no further step is due here.)
|
||||
@ -1,72 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2024-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: imageName
|
||||
type: string
|
||||
- name: imageBase
|
||||
type: object
|
||||
|
||||
jobs:
|
||||
- job: SetupImage_${{parameters.imageName}}
|
||||
displayName: Build ${{parameters.imageName}} image
|
||||
condition: eq(variables.setupImages, true)
|
||||
container:
|
||||
image: devfra.azurecr.io/de.fraport.build/tools:1.1.0
|
||||
endpoint: devfra
|
||||
steps:
|
||||
- task: Docker@2
|
||||
displayName: Login to container registry
|
||||
inputs:
|
||||
command: login
|
||||
containerRegistry: devfra
|
||||
- task: Bash@3
|
||||
displayName: Build ${{parameters.imageName}} image
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
cp docker/${{parameters.imageName}}/Dockerfile .
|
||||
docker build \
|
||||
--tag $(buildImageUpstream)/${{parameters.imageName}}:$(Build.BuildNumber) \
|
||||
--build-arg FROM_IMG=${{parameters.imageBase.image}} \
|
||||
--build-arg FROM_TAG=${{parameters.imageBase.tag}} \
|
||||
--build-arg HTTPS_PROXY=http://proxy.frankfurt-airport.de:8080 \
|
||||
--build-arg HTTP_PROXY=http://proxy.frankfurt-airport.de:8080 \
|
||||
--build-arg NO_PROXY='localhost,127.0.0.1,*.docker.internal,*.azmk8s.io,devfra.azurecr.io,devfra.westeurope.data.azurecr.io' \
|
||||
--build-arg FRAPORT_NOPROXY=dev.azure.com,*.dev.azure.com,*.fraport.de,*.frankfurt-airport.de \
|
||||
--build-arg PROJECT_DIR=$(Build.Repository.LocalPath) \
|
||||
--build-arg IN_CI=true \
|
||||
--build-arg IN_CONTAINER=true \
|
||||
.
|
||||
- task: Bash@3
|
||||
displayName: Push ${{parameters.imageName}} image
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
docker push $(buildImageUpstream)/${{parameters.imageName}}:$(Build.BuildNumber)
|
||||
- task: Bash@3
|
||||
displayName: Update latest ${{parameters.imageName}} image
|
||||
condition: or(eq(variables.forcePushLatest, true), eq(variables['Build.SourceBranch'], 'refs/heads/master'))
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
docker tag $(buildImageUpstream)/${{parameters.imageName}}:$(Build.BuildNumber) $(buildImageUpstream)/${{parameters.imageName}}:latest
|
||||
docker push $(buildImageUpstream)/${{parameters.imageName}}:latest
|
||||
- task: Bash@3
|
||||
displayName: Save image for publication
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
docker image save --output=$(Build.ArtifactStagingDirectory)/${{parameters.imageName}}.tar $(buildImageUpstream)/${{parameters.imageName}}:$(Build.BuildNumber)
|
||||
- task: PublishBuildArtifacts@1
|
||||
displayName: Publish image as artifact
|
||||
inputs:
|
||||
PathtoPublish: '$(Build.ArtifactStagingDirectory)'
|
||||
ArtifactName: Image_${{parameters.imageName}}
|
||||
publishLocation: 'Container'
|
||||
- task: Docker@2
|
||||
displayName: Logout from container registry
|
||||
inputs:
|
||||
command: logout
|
||||
containerRegistry: devfra
|
||||
@ -1,141 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2024-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: serviceName
|
||||
type: string
|
||||
default: serviceName
|
||||
- name: serviceBase
|
||||
type: object
|
||||
default:
|
||||
image: baseImage
|
||||
tag: baseImageTag
|
||||
- name: servicePool
|
||||
type: string
|
||||
default: 'Prod Private Agent Pool'
|
||||
- name: serviceTimeout
|
||||
type: number
|
||||
default: 60
|
||||
# extraBuildOptions: ''
|
||||
- name: serviceDependsOn
|
||||
type: object
|
||||
default: []
|
||||
- name: serviceRequiredArtifacts
|
||||
type: object
|
||||
default: []
|
||||
- name: serviceArtifacts
|
||||
type: string
|
||||
default: ''
|
||||
- name: buildSteps
|
||||
type: object
|
||||
|
||||
stages:
|
||||
- stage: ${{ parameters.serviceName }}
|
||||
dependsOn: ${{ parameters.serviceDependsOn }}
|
||||
pool: '${{ parameters.servicePool }}'
|
||||
jobs:
|
||||
- job: ImageBuild_${{parameters.serviceName}}
|
||||
displayName: Build ${{parameters.serviceName}} image
|
||||
condition: or(eq(variables.forcePushLatest, true), eq(variables.onMasterBranch, true), eq(variables.onUpdateBranch, true))
|
||||
container:
|
||||
image: devfra.azurecr.io/de.fraport.build/tools:1.1.0
|
||||
endpoint: devfra
|
||||
steps:
|
||||
- checkout: self
|
||||
- task: Docker@2
|
||||
displayName: Login to container registry
|
||||
inputs:
|
||||
command: login
|
||||
containerRegistry: devFra
|
||||
- script: |
|
||||
ls -a .
|
||||
pwd
|
||||
find .
|
||||
- task: Bash@3
|
||||
displayName: Build ${{parameters.serviceName}} image
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
cp docker/${{parameters.serviceName}}/Dockerfile .
|
||||
docker build \
|
||||
--tag $(buildImageUpstream)/${{parameters.serviceName}}:$(Build.BuildNumber) \
|
||||
--build-arg FROM_IMG=${{parameters.serviceBase.image}} \
|
||||
--build-arg FROM_TAG=${{parameters.serviceBase.tag}} \
|
||||
--build-arg HTTPS_PROXY=http://proxy.frankfurt-airport.de:8080 \
|
||||
--build-arg HTTP_PROXY=http://proxy.frankfurt-airport.de:8080 \
|
||||
--build-arg NO_PROXY='localhost,127.0.0.1,*.docker.internal,*.azmk8s.io,devfra.azurecr.io,devfra.westeurope.data.azurecr.io' \
|
||||
--build-arg FRAPORT_NOPROXY=dev.azure.com,*.dev.azure.com,*.fraport.de,*.frankfurt-airport.de \
|
||||
--build-arg PROJECT_DIR=$(Build.Repository.LocalPath) \
|
||||
--build-arg IN_CI=true \
|
||||
--build-arg IN_CONTAINER=true \
|
||||
.
|
||||
- task: Bash@3
|
||||
displayName: Push ${{ parameters.serviceName }} image
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
docker push $(buildImageUpstream)/${{parameters.serviceName}}:$(Build.BuildNumber)
|
||||
- task: Bash@3
|
||||
displayName: Update latest ${{parameters.serviceName}} image
|
||||
condition: or(eq(variables.forcePushLatest, true), eq(variables.onMasterBranch, true))
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
docker tag $(buildImageUpstream)/${{parameters.serviceName}}:$(Build.BuildNumber) $(buildImageUpstream)/${{parameters.serviceName}}:latest
|
||||
docker push $(buildImageUpstream)/${{parameters.serviceName}}:latest
|
||||
- task: Docker@2
|
||||
displayName: Logout from container registry
|
||||
inputs:
|
||||
command: logout
|
||||
containerRegistry: devFra
|
||||
|
||||
- job: Build_${{parameters.serviceName}}
|
||||
displayName: Build ${{parameters.serviceName}}
|
||||
dependsOn:
|
||||
- ImageBuild_${{parameters.serviceName}}
|
||||
condition: in(dependencies.ImageBuild_${{parameters.serviceName}}.result, 'Succeeded', 'Skipped')
|
||||
timeoutInMinutes: ${{ parameters.serviceTimeout }}
|
||||
container:
|
||||
# TODO: use BuildNumber instead of latest in update branches
|
||||
# image: devfra.azurecr.io/de.fraport.fradrive.build/frontend:$(Build.BuildNumber)
|
||||
image: $(buildImageUpstream)/${{parameters.serviceName}}:latest
|
||||
endpoint: devfra
|
||||
env:
|
||||
PROJECT_DIR: $(Build.Repository.LocalPath)
|
||||
IN_CONTAINER: true
|
||||
IN_CI: true
|
||||
steps:
|
||||
- checkout: self
|
||||
- ${{ each dependency in parameters.serviceRequiredArtifacts }}:
|
||||
- task: DownloadPipelineArtifact@2
|
||||
displayName: Download artifacts from ${{ dependency.name }} dependency
|
||||
continueOnError: ${{ dependency.continueOnError }}
|
||||
condition: ${{ dependency.condition }}
|
||||
inputs:
|
||||
artifactName: ${{ dependency.artifact }}
|
||||
source: ${{ dependency.source }}
|
||||
project: 'Fahrerausbildung'
|
||||
pipeline: $(System.DefinitionId)
|
||||
buildVersionToDownload: '${{ dependency.version }}'
|
||||
tags: '${{ dependency.artifact }}'
|
||||
allowPartiallySucceededBuilds: true
|
||||
allowFailedBuilds: true
|
||||
patterns: '${{ dependency.patterns }}'
|
||||
targetPath: '$(Build.Repository.LocalPath)'
|
||||
- ${{ each buildStep in parameters.buildSteps }}:
|
||||
- template: ./service/build-step.yaml
|
||||
parameters:
|
||||
service: ${{ parameters.serviceName }}
|
||||
buildStep: ${{ buildStep }}
|
||||
- task: CopyFiles@2
|
||||
displayName: Copy ${{parameters.serviceName}} artifacts
|
||||
inputs:
|
||||
Contents: ${{ parameters.serviceArtifacts }}
|
||||
TargetFolder: '$(Build.ArtifactStagingDirectory)'
|
||||
- task: PublishBuildArtifacts@1
|
||||
displayName: Publish ${{parameters.serviceName}} artifacts
|
||||
inputs:
|
||||
PathtoPublish: '$(Build.ArtifactStagingDirectory)'
|
||||
ArtifactName: '${{parameters.serviceName}}'
|
||||
publishLocation: 'Container'
|
||||
@ -1,15 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: artifactName
|
||||
type: string
|
||||
|
||||
steps:
|
||||
- task: DownloadPipelineArtifact@2
|
||||
displayName: Download artifacts from ${{parameters.artifactName}}
|
||||
inputs:
|
||||
source: 'current'
|
||||
artifactName: '${{parameters.artifactName}}'
|
||||
targetPath: '$(Build.Repository.LocalPath)'
|
||||
@ -1,18 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: cacheIdent
|
||||
type: string
|
||||
- name: cacheKeys
|
||||
type: string
|
||||
- name: cachePath
|
||||
type: string
|
||||
|
||||
steps:
|
||||
- task: Cache@2
|
||||
displayName: Restore ${{parameters.cacheIdent}} cache
|
||||
inputs:
|
||||
key: '"${{parameters.cacheIdent}}" | ${{parameters.cacheKeys}}'
|
||||
path: '${{parameters.cachePath}}'
|
||||
@ -1,35 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2024-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
parameters:
|
||||
- name: makeJob
|
||||
type: string
|
||||
values:
|
||||
- dependencies
|
||||
- compile
|
||||
- lint
|
||||
- test
|
||||
- name: makeService
|
||||
type: string
|
||||
values:
|
||||
- frontend
|
||||
- backend
|
||||
- name: makeVars
|
||||
type: string
|
||||
default: ''
|
||||
|
||||
steps:
|
||||
- task: Bash@3
|
||||
name: ${{parameters.makeJob}}_${{parameters.makeService}}
|
||||
displayName: make ${{parameters.makeJob}}-${{parameters.makeService}}
|
||||
env:
|
||||
HTTPS_PROXY: http://proxy.frankfurt-airport.de:8080
|
||||
HTTP_PROXY: http://proxy.frankfurt-airport.de:8080
|
||||
NO_PROXY: 'localhost,127.0.0.1,*.docker.internal,*.azmk8s.io,devfra.azurecr.io,devfra.westeurope.data.azurecr.io'
|
||||
FRAPORT_NOPROXY: 'dev.azure.com,*.dev.azure.com,*.fraport.de,*.frankfurt-airport.de'
|
||||
PROJECT_DIR: $(Build.Repository.LocalPath)
|
||||
inputs:
|
||||
targetType: inline
|
||||
script: |
|
||||
make -- --${{parameters.makeJob}}-${{parameters.makeService}} IN_CONTAINER=true IN_CI=true PROJECT_DIR=${PROJECT_DIR} ${{parameters.makeVars}}
|
||||
3
.babelrc.license
Normal file
3
.babelrc.license
Normal file
@ -0,0 +1,3 @@
|
||||
SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
|
||||
SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
3
.eslintrc.json.license
Normal file
3
.eslintrc.json.license
Normal file
@ -0,0 +1,3 @@
|
||||
SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
|
||||
SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
21
.gitignore
vendored
21
.gitignore
vendored
@ -2,12 +2,9 @@
|
||||
dist*
|
||||
develop
|
||||
node_modules/
|
||||
.npm/
|
||||
.node_repl_history
|
||||
**/assets/icons
|
||||
**/assets/favicons
|
||||
assets/icons
|
||||
assets/favicons
|
||||
bin/
|
||||
assets/fonts/
|
||||
*.hi
|
||||
*.o
|
||||
*.sqlite3
|
||||
@ -42,19 +39,19 @@ src/Handler/Assist.bak
|
||||
src/Handler/Course.SnapCustom.hs
|
||||
*.orig
|
||||
/instance
|
||||
backend/instance
|
||||
.stack-work-*
|
||||
.stack-work.lock
|
||||
.directory
|
||||
tags
|
||||
test.log
|
||||
*.dump-splices
|
||||
/.stack-work.lock
|
||||
/.npmrc
|
||||
/.npm/
|
||||
/config/manifest.json
|
||||
tunnel.log
|
||||
static
|
||||
well-known
|
||||
.well-known-cache
|
||||
manifest.json
|
||||
/static
|
||||
/well-known
|
||||
/.well-known-cache
|
||||
/.nix-well-known
|
||||
/**/tmp-*
|
||||
/testdata/bigAlloc_*.csv
|
||||
@ -68,4 +65,4 @@ manifest.json
|
||||
**/result-*
|
||||
.develop.cmd
|
||||
/.vscode
|
||||
backend/.ghc/ghci_history
|
||||
.ghc/ghci_history
|
||||
|
||||
@ -6,11 +6,8 @@ use warnings;
|
||||
use Data::Dumper;
|
||||
|
||||
# Version changes:
|
||||
# [x].[y].[z] -- Main version number
|
||||
# XXX old
|
||||
# [x].[y].[z]-test-[branchstring]-[num] -- test/branch/devel version number
|
||||
# XXX new
|
||||
# [x].[y].[z]-[num]+[branchname]
|
||||
# v[x].[y].[z] -- Main version number
|
||||
# v[x].[y].[z]-test-[branchstring]-num -- test/branch/devel version number
|
||||
# on main/master: Biggest version so far, increment by occuring changes
|
||||
# on other branches: find version; be it branch string, old format or main version number;
|
||||
# increments from there. Increment version number, but on global conflict use new version number
|
||||
@ -55,12 +52,12 @@ my %parKinds = (
|
||||
},
|
||||
autokind=>{
|
||||
arity=>1,
|
||||
def=>'release/prod=v,release/*=t,*=t',
|
||||
def=>'main=v,master=v,test=t,*=t',
|
||||
help=>'determine the tag kind from branch name instead of fixed value; use the first fitting glob',
|
||||
},
|
||||
change=>{
|
||||
arity=>1,
|
||||
def=>'chore=patch,feat=minor,feature=minor,fix=patch,BREAK=major,perf=patch,refactor=patch,test=patch,style=patch,revert=patch,docs=patch,build=patch,ci=patch',
|
||||
def=>'chore=patch,feat=minor,feature=minor,fix=patch,BREAK=major,perf=patch,refactor=patch,test=patch,style=patch,revert=null,docs=patch,build=null,ci=null',
|
||||
help=>'how to react on which commit type; can be partially given. Actions are: "null", "major", "minor", "patch" or state "invalid" for removing this type',
|
||||
},
|
||||
changelog=>{
|
||||
@ -136,14 +133,11 @@ if($par{'h'}) {
|
||||
exit 0
|
||||
}
|
||||
|
||||
my $branchNameEscaped = `$par{vcsbranch}`;
|
||||
chomp $branchNameEscaped;
|
||||
if($par{autokind}) {
|
||||
my $branch = $branchNameEscaped;
|
||||
my $branch = `$par{vcsbranch}`;
|
||||
my @rules = split /,/, $par{autokind};
|
||||
RULES: {
|
||||
for my $r(@rules) {
|
||||
warn "$0: Processing autokind rule '$r'\n" if $par{v};
|
||||
if($r!~m#(.*)=(.*)#) {
|
||||
die "$0: Bad rule in autokind: $r\n";
|
||||
}
|
||||
@ -156,18 +150,17 @@ if($par{autokind}) {
|
||||
warn "$0: No autokind rule matches; leaving the kind unchanged.\n"
|
||||
}
|
||||
}
|
||||
$branchNameEscaped =~ s/[^0-9a-zA-Z]+/-/g;
|
||||
|
||||
|
||||
if($par{'v'}) {
|
||||
warn "VERBOSE: Parameters\n";
|
||||
print "VERBOSE: Parameters\n";
|
||||
for my $k(sort keys %par) {
|
||||
warn " $k: $par{$k}\n"
|
||||
print " $k: $par{$k}\n"
|
||||
}
|
||||
}
|
||||
|
||||
my %typeReact = ();
|
||||
for my $as(split /,/, $par{change}) {
|
||||
warn "$0: processing change parameter '$as'\n" if $par{v};
|
||||
if($as=~m#(.*)=(.*)#) {
|
||||
$typeReact{$1} = $2;
|
||||
} else {
|
||||
@ -231,36 +224,47 @@ sub parseVersion {
|
||||
warn "$0: internal error (parseVersion called on undef at $c)\n";
|
||||
return undef
|
||||
}
|
||||
my %cap = ();
|
||||
if(
|
||||
$v=~m#^(?<pre>[a-z]*)(?<ma>[0-9]+)$# ||
|
||||
$v=~m#^(?<pre>[a-z]*)(?<ma>[0-9]+)\.(?<mi>[0-9]+)$# ||
|
||||
$v=~m#^(?<pre>[a-z]*)(?<ma>[0-9]+)\.(?<mi>[0-9]+)\.(?<p>[0-9]+)$# ||
|
||||
$v=~m#^(?<pre>[a-z]*)(?<ma>[0-9]+)\.(?<mi>[0-9]+)\.(?<p>[0-9]+)-test-(?<sp>(?<brn>[a-z]+)-?(?<brv>[0-9\.]+))$# ||
|
||||
$v=~m#^(?<pre>[a-z]*)(?<ma>[0-9]+)\.(?<mi>[0-9]+)\.(?<p>[0-9]+)-(?<sp>(?<brv>[0-9\.]+)\+(?<brn>[0-9A-Za-z\-]+))$# || # [x].[y].[z]-[num]+[branchname]
|
||||
$v=~m#^(?<pre>[a-z]*)(?<ma>[0-9]+)\.(?<mi>[0-9]+)\.(?<p>[0-9]+)-(?<sp>.*)$#
|
||||
) {
|
||||
%cap = %+
|
||||
# my ($pre,$ma,$mi,$p,$sp,$brn,$brv) = ();
|
||||
my ($pre,$ma,$mi,$p,$sp,$brn,$brv) = ();
|
||||
if($v=~m#^([a-z]*)([0-9]+)$#) {
|
||||
$pre = $1;
|
||||
$ma = $2;
|
||||
} elsif($v=~m#^([a-z]*)([0-9]+)\.([0-9]+)$#) {
|
||||
$pre = $1;
|
||||
$ma = $2;
|
||||
$mi = $3
|
||||
} elsif($v=~m#^([a-z]*)([0-9]+)\.([0-9]+)\.([0-9]+)$#) {
|
||||
$pre = $1;
|
||||
$ma = $2;
|
||||
$mi = $3;
|
||||
$p = $4;
|
||||
} elsif($v=~m#^([a-z]*)([0-9]+)\.([0-9]+)\.([0-9]+)-test-([a-z]+)-([0-9\.]+)$#) {
|
||||
$pre = $1;
|
||||
$ma = $2;
|
||||
$mi = $3;
|
||||
$p = $4;
|
||||
$sp = $5;
|
||||
$brn = $6;
|
||||
$brv = $7;
|
||||
} elsif($v=~m#^([a-z]*)([0-9]+)\.([0-9]+)\.([0-9]+)-(.*)$#) {
|
||||
$pre = $1;
|
||||
$ma = $2;
|
||||
$mi = $3;
|
||||
$p = $4;
|
||||
$sp = $5;
|
||||
} else {
|
||||
warn "$0: unexpected old version number: $v\n" if $par{v};
|
||||
return undef
|
||||
}
|
||||
$cap{pre} = 'v' if '' eq $cap{pre};
|
||||
my %ret = (
|
||||
prefix=>$cap{pre},
|
||||
major=>$cap{ma},
|
||||
minor=>$cap{mi},
|
||||
patch=>$cap{p},
|
||||
subpatch=>$cap{sp},
|
||||
branchname=>$cap{brn},
|
||||
branchversion=>$cap{brv},
|
||||
);
|
||||
if($par{v}) {
|
||||
my $parsed = join '; ', map { "$_=>".($ret{$_}//'') } sort keys %ret;
|
||||
warn "Version '$v' was parsed to '$parsed'\n"
|
||||
$pre = 'v' if '' eq $pre;
|
||||
return {
|
||||
prefix=>$pre,
|
||||
major=>$ma,
|
||||
minor=>$mi,
|
||||
patch=>$p,
|
||||
subpatch=>$sp,
|
||||
branchname=>$brn,
|
||||
branchversion=>$brv,
|
||||
}
|
||||
return \%ret
|
||||
}
|
||||
|
||||
#@oldVersions = sort {
|
||||
@ -294,18 +298,18 @@ sub vsCompare {
|
||||
#for($v, $w) {
|
||||
# $_ = parseVersion($_) unless ref $_;
|
||||
#}
|
||||
if($v->{prefix}=~m/^v?$/ and $w->{prefix}=~m/^v?$/) {
|
||||
if('v' eq $v->{prefix} and 'v' eq $w->{prefix}) {
|
||||
return(
|
||||
($v->{major} // 0) <=> ($w->{major} // 0) ||
|
||||
($v->{minor} // 0) <=> ($w->{minor} // 0) ||
|
||||
($v->{patch} // 0) <=> ($w->{patch} // 0) ||
|
||||
($v->{branchname} // '') cmp ($w->{branchname} // '') ||
|
||||
($v->{branchversion} // 0) <=> ($w->{branchversion} // 0) ||
|
||||
($v->{branchversion} // '') <=> ($w->{branchversion} // '') ||
|
||||
($v->{subpatch} // '') cmp ($w->{subpatch} // '')
|
||||
)
|
||||
} elsif($v->{prefix}=~m/^v?$/ and !$w->{prefix}=~m/^v?$/) {
|
||||
} elsif('v' eq $v->{prefix} and 'v' ne $w->{prefix}) {
|
||||
return 1;
|
||||
} elsif(!$v->{prefix}=~m/^v?$/ and $w->{prefix}=~m/^v?$/) {
|
||||
} elsif('v' ne $v->{prefix} and 'v' eq $w->{prefix}) {
|
||||
return -1;
|
||||
} else {
|
||||
return vsStringDebug($v) cmp vsStringDebug($w)
|
||||
@ -345,21 +349,13 @@ sub vsJustVersion {
|
||||
|
||||
sub vsTestVersion {
|
||||
my $v = shift;
|
||||
# [x].[y].[z]-[num]+[branchname]
|
||||
my $ret =
|
||||
'v' .
|
||||
($v->{major} // 0) . "." .
|
||||
($v->{minor} // 0) . "." .
|
||||
($v->{patch} // 0) . "-" .
|
||||
($v->{branchversion} // '0.0.0') . "+" .
|
||||
$branchNameEscaped;
|
||||
# old version format
|
||||
#my $ret =
|
||||
#'v' .
|
||||
#($v->{major} // 0) . "." .
|
||||
#($v->{minor} // 0) . "." .
|
||||
#($v->{patch} // 0) . "-test-" .
|
||||
#($v->{branchname} // 'a') .
|
||||
#($v->{branchversion} // '0.0.0');
|
||||
($v->{patch} // 0) . "-test-" .
|
||||
($v->{branchname} // 'a') .
|
||||
($v->{branchversion} // '0.0.0');
|
||||
return $ret
|
||||
}
|
||||
|
||||
@ -376,7 +372,6 @@ if('-' eq $par{vcslog}) {
|
||||
}
|
||||
my @versions = ();
|
||||
for my $v(@versionsOrig) {
|
||||
warn "$0: Processing orig version (part 1): '$v'\n" if $par{v};
|
||||
if($v=~m#^(.*?\S)\s*::::\s*(.*?)\s*::::\s*(.*)#) {
|
||||
push @versions, {
|
||||
hash => $1,
|
||||
@ -394,14 +389,12 @@ my $tag = undef;
|
||||
my @versionPast = ();
|
||||
|
||||
VERSION: for my $v(@versions) {
|
||||
warn "$0: Processing version (part 2): $v\n" if $par{v};
|
||||
#if($v->{meta}=~m#tag\s*:\s*\Q$par{kind}\E(.*)\)#) {
|
||||
# $tag=$1;
|
||||
# last VERSION
|
||||
#}
|
||||
if($v->{meta}=~m#tag\s*:\s*((?:[vtd]|db|)[0-9\.]+(?:[a-zA-Z\-\+0-9\.]*)?)[\),]#) {
|
||||
if($v->{meta}=~m#tag\s*:\s*([vtd]b?[0-9\.]+(?:-.*)?)\)#) {
|
||||
$v->{version} = $1;
|
||||
warn "$0: Found version number in log: '$v->{version}'\n" if $par{v};
|
||||
push @versionPast, $v->{version}
|
||||
}
|
||||
next if $v->{subject}=~m#^\s*(?:Merge (?:branch|remote)|Revert )#;
|
||||
@ -424,7 +417,6 @@ VERSION: for my $v(@versions) {
|
||||
#$tag = parseVersion($tag);
|
||||
|
||||
for my $r(reverse @change) {
|
||||
warn "$0: Processing change: $r\n" if $par{v};
|
||||
if('major' eq $r->{react}) {
|
||||
$tag->{major}++;
|
||||
$tag->{minor}=0;
|
||||
@ -459,11 +451,8 @@ for my $r(reverse @change) {
|
||||
|
||||
my @allVersions = split /\n/, `$par{vcstags}`;
|
||||
|
||||
#my @sortAll = sort {vsCompare($b, $a)} @allVersions;
|
||||
#my @sortSee = sort {vsCompare($b, $a)} @versionPast;
|
||||
# we want the latest version and do not sort
|
||||
my @sortAll = @allVersions;
|
||||
my @sortSee = @versionPast;
|
||||
my @sortAll = sort {vsCompare($b, $a)} @allVersions;
|
||||
my @sortSee = sort {vsCompare($b, $a)} @versionPast;
|
||||
#print "all: $sortAll[0] -- see: $sortSee[0]\n";
|
||||
#
|
||||
#print vsString($tag), "\n";
|
||||
@ -474,7 +463,6 @@ my $highStart = $mainVersion ? $sortAll[0] : $sortSee[0];
|
||||
my $highSee = $sortSee[0];
|
||||
my %reactCollect = ();
|
||||
SEARCHVERSION: for my $v(@versions) {
|
||||
warn "$0: search for version: '$v'\n" if $par{v};
|
||||
next unless $v->{version};
|
||||
next unless $v->{react};
|
||||
$reactCollect{$v->{react}} = 1;
|
||||
@ -486,18 +474,16 @@ SEARCHVERSION: for my $v(@versions) {
|
||||
sub justVersionInc {
|
||||
my ($v, $react) = @_;
|
||||
my $vv = parseVersion($v);
|
||||
$vv->{patch}++; # if $react->{patch}; # in principal a good idea to increase only when a patch action happend, but we need a new version, even if nothing happend, so we always increase patch; if there are other changes as well, it is overwritten anyways
|
||||
$vv->{patch}++ if $react->{patch};
|
||||
do {$vv->{minor}++; $vv->{patch}=0} if $react->{minor};
|
||||
do {$vv->{major}++; $vv->{minor}=0; $vv->{patch}=0} if $react->{major};
|
||||
my $ret = vsJustVersion($vv);
|
||||
warn "$0: version inc from '$v' to $ret\n" if $par{v};
|
||||
return $ret
|
||||
return vsJustVersion($vv);
|
||||
}
|
||||
|
||||
my $newVersion = undef;
|
||||
|
||||
if($mainVersion) {
|
||||
$newVersion = justVersionInc($highStart, \%reactCollect);
|
||||
$newVersion = "v" . justVersionInc($highStart, \%reactCollect);
|
||||
} else {
|
||||
my $v = parseVersion($highStart);
|
||||
if(exists $v->{branchname}) {
|
||||
@ -514,7 +500,6 @@ for(@allVersions) {
|
||||
$allVersions{$_} = 1
|
||||
}
|
||||
while(exists $allVersions{$newVersion}) {
|
||||
warn "$0: Version conflict, so we try another version, '$newVersion' exists already\n" if $par{v};
|
||||
if($mainVersion) {
|
||||
die "$0: probably internal error (collision in main version)\n"
|
||||
}
|
||||
@ -544,7 +529,6 @@ if($par{changelog}) {
|
||||
my %seen = ();
|
||||
my @sects = ([]);
|
||||
for(@changelog) {
|
||||
warn "$0: Changelog processing: '$_'\n" if $par{v};
|
||||
push @sects, [] if m/^## /;
|
||||
push @{$sects[-1]}, $_;
|
||||
if(m#/commit/([a-f0-9]+)\s*\)\s*\)\s*$#) {
|
||||
@ -558,7 +542,6 @@ if($par{changelog}) {
|
||||
shift @sects;
|
||||
}
|
||||
for my $s(@sects) {
|
||||
warn "$0: Changelog processing, section search: '$s'\n" if $par{v};
|
||||
my $hh = $s->[0];
|
||||
chomp $hh;
|
||||
my $cnt = @$s;
|
||||
@ -583,7 +566,6 @@ if($par{changelog}) {
|
||||
'feature' => 'Features',
|
||||
);
|
||||
SELECTCHANGELOG: for my $v(@versions) {
|
||||
warn "$0: Changelog processing, version selection: '$v'\n" if $par{v};
|
||||
last SELECTCHANGELOG if $seen{$v->{hash}};
|
||||
next unless $v->{subject}=~m#^\s*([a-z]+)\s*(!?)\s*((?:\(.*?\))?)\s*:\s*(.*?)\s*$#i;
|
||||
my ($kind, $break, $context, $msg) = ($1, $2, $3, $4);
|
||||
@ -607,7 +589,7 @@ if($par{changelog}) {
|
||||
my $preVersion = '';
|
||||
if(defined $sects[0] and defined $sects[0][0] and $sects[0][0]=~m/^##\s*\[([^\]\[]+)\]\(/) {
|
||||
$preVersion = $1;
|
||||
# $preVersion =~ s#^v?#v#;
|
||||
$preVersion =~ s#^v?#v#;
|
||||
}
|
||||
my $today = do {
|
||||
my @time = localtime;
|
||||
@ -636,3 +618,11 @@ All notable changes to this project will be documented in this file. See [standa
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -7,33 +7,33 @@ const standardVersionUpdaterYaml = require.resolve('standard-version-updater-yam
|
||||
module.exports = {
|
||||
scripts: {
|
||||
// postbump: './sync-versions.hs && git add -- package.yaml', // moved to bumpFiles
|
||||
postchangelog: 'sed \'s/^### \\[/## [/g\' -i CHANGELOG.md',
|
||||
postchangelog: 'sed \'s/^### \\[/## [/g\' -i CHANGELOG.md'
|
||||
},
|
||||
packageFiles: ['package.json', 'package.yaml'],
|
||||
bumpFiles: [
|
||||
{
|
||||
filename: 'package.json',
|
||||
type: 'json',
|
||||
type: 'json'
|
||||
},
|
||||
{
|
||||
filename: 'package-lock.json',
|
||||
type: 'json',
|
||||
type: 'json'
|
||||
},
|
||||
{
|
||||
filename: 'package.yaml',
|
||||
updater: standardVersionUpdaterYaml,
|
||||
updater: standardVersionUpdaterYaml
|
||||
},
|
||||
{
|
||||
filename: 'nix/docker/version.json',
|
||||
type: 'json',
|
||||
type: 'json'
|
||||
},
|
||||
{
|
||||
filename: 'nix/docker/demo-version.json',
|
||||
type: 'json',
|
||||
},
|
||||
type: 'json'
|
||||
}
|
||||
],
|
||||
commitUrlFormat: 'https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/{{hash}}',
|
||||
compareUrlFormat: 'https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/{{previousTag}}...{{currentTag}}',
|
||||
issueUrlFormat: 'https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/{{id}}',
|
||||
userUrlFormat: 'https://gitlab2.rz.ifi.lmu.de/{{user}}',
|
||||
userUrlFormat: 'https://gitlab2.rz.ifi.lmu.de/{{user}}'
|
||||
};
|
||||
|
||||
66
CHANGELOG.md
66
CHANGELOG.md
@ -2,72 +2,6 @@
|
||||
|
||||
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.
|
||||
|
||||
## [27.4.59-0.0.20+145-build-system-rewrite](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/27.4.59-0.0.19+145-build-system-rewrite...27.4.59-0.0.20+145-build-system-rewrite) (2025-03-19)
|
||||
|
||||
## [27.4.59-0.0.19+145-build-system-rewrite](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/27.4.59-0.0.18+145-build-system-rewrite...27.4.59-0.0.19+145-build-system-rewrite) (2025-03-17)
|
||||
|
||||
## [27.4.59-0.0.18+145-build-system-rewrite](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-g0.0.17...27.4.59-0.0.18+145-build-system-rewrite) (2025-03-17)
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **static:** fix addStaticContent by using memcached again to supply static files ([570cfc2](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive/commit/570cfc238bdccd3438124f96290b9272c8e82f0f))
|
||||
|
||||
## [v27.4.59-test-g0.0.17](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-f0.0.17...v27.4.59-test-g0.0.17) (2025-02-18)
|
||||
|
||||
## [v27.4.59-test-f0.0.17](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-g0.0.16...v27.4.59-test-f0.0.17) (2025-02-17)
|
||||
|
||||
## [v27.4.59-test-g0.0.16](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-f0.0.16...v27.4.59-test-g0.0.16) (2025-02-16)
|
||||
|
||||
## [v27.4.59-test-f0.0.16](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-f0.0.15...v27.4.59-test-f0.0.16) (2025-02-16)
|
||||
|
||||
## [v27.4.59-test-f0.0.15](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-e0.0.15...v27.4.59-test-f0.0.15) (2025-02-15)
|
||||
|
||||
## [v27.4.59-test-e0.0.15](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-f0.0.14...v27.4.59-test-e0.0.15) (2025-02-14)
|
||||
|
||||
## [v27.4.59-test-f0.0.14](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-e0.0.14...v27.4.59-test-f0.0.14) (2025-02-14)
|
||||
|
||||
## [v27.4.59-test-e0.0.14](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-e0.0.13...v27.4.59-test-e0.0.14) (2025-02-13)
|
||||
|
||||
## [v27.4.59-test-e0.0.13](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-e0.0.12...v27.4.59-test-e0.0.13) (2025-02-12)
|
||||
|
||||
## [v27.4.59-test-e0.0.12](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-d0.0.12...v27.4.59-test-e0.0.12) (2025-02-12)
|
||||
|
||||
## [v27.4.59-test-d0.0.12](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-d0.0.11...v27.4.59-test-d0.0.12) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-d0.0.11](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-c0.0.11...v27.4.59-test-d0.0.11) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-c0.0.11](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-b0.0.11...v27.4.59-test-c0.0.11) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-b0.0.11](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-c0.0.10...v27.4.59-test-b0.0.11) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-c0.0.10](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-b0.0.10...v27.4.59-test-c0.0.10) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-b0.0.10](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.10...v27.4.59-test-b0.0.10) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-a0.0.10](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.9...v27.4.59-test-a0.0.10) (2025-02-11)
|
||||
|
||||
## [v27.4.59-test-a0.0.9](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.8...v27.4.59-test-a0.0.9) (2025-02-10)
|
||||
|
||||
## [v27.4.59-test-a0.0.8](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.7...v27.4.59-test-a0.0.8) (2025-02-10)
|
||||
|
||||
## [v27.4.59-test-a0.0.7](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.6...v27.4.59-test-a0.0.7) (2025-02-10)
|
||||
|
||||
## [v27.4.59-test-a0.0.6](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.5...v27.4.59-test-a0.0.6) (2025-02-08)
|
||||
|
||||
## [v27.4.59-test-a0.0.5](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.4...v27.4.59-test-a0.0.5) (2025-02-07)
|
||||
|
||||
## [v27.4.59-test-a0.0.4](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.3...v27.4.59-test-a0.0.4) (2025-02-07)
|
||||
|
||||
## [v27.4.59-test-a0.0.3](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.2...v27.4.59-test-a0.0.3) (2025-02-06)
|
||||
|
||||
## [v27.4.59-test-a0.0.2](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.1...v27.4.59-test-a0.0.2) (2025-02-05)
|
||||
|
||||
## [v27.4.59-test-a0.0.1](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-a0.0.0...v27.4.59-test-a0.0.1) (2025-02-05)
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **ghci:** ghci works now as expected ([c3117db](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive/commit/c3117dbdcd1de9ef9f0751afa45018e2ebce2c42))
|
||||
|
||||
## [v27.4.59-test-a0.0.0](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59...v27.4.59-test-a0.0.0) (2024-10-25)
|
||||
|
||||
### Features
|
||||
|
||||
469
Makefile
469
Makefile
@ -1,123 +1,414 @@
|
||||
|
||||
export SHELL=bash
|
||||
|
||||
export CLEAN_DEPENDENCIES ?= false
|
||||
export CLEAN_IMAGES ?= false
|
||||
# MAKE=make -f Makefile-loggingsymbols
|
||||
# MAKE=make -d
|
||||
|
||||
export ENTRYPOINT ?= bash
|
||||
# System information
|
||||
export CPU_CORES = $(shell cat /proc/cpuinfo | grep '^processor' | wc -l)
|
||||
|
||||
export CONTAINER_COMMAND ?= podman
|
||||
export CONTAINER_BGRUN ?= $(CONTAINER_COMMAND) run -dit --network=host --replace
|
||||
export CONTAINER_FGRUN ?= $(CONTAINER_COMMAND) run -it --network=host --replace
|
||||
|
||||
export IMAGE_REGISTRY = docker.io
|
||||
export MEMCACHED_IMAGE = $(IMAGE_REGISTRY)/memcached:latest
|
||||
export MINIO_IMAGE = $(IMAGE_REGISTRY)/minio/minio:latest
|
||||
export MAILDEV_IMAGE = $(IMAGE_REGISTRY)/maildev/maildev:latest # TODO: needs different port than 1025 to avoid conflicts
|
||||
|
||||
export IN_CONTAINER ?= false
|
||||
export IN_CI ?= false
|
||||
export CONTAINER_FILE
|
||||
export CONTAINER_IDENT
|
||||
export CF_PREFIX
|
||||
export DEVELOP
|
||||
export MOUNT_DIR=/mnt/fradrive
|
||||
export CONTAINER_ATTACHED
|
||||
export CONTAINER_INIT
|
||||
export CONTAINER_CLEANUP
|
||||
|
||||
export SERVICE
|
||||
export SERVICE_VARIANT ?= $(SERVICE)
|
||||
export JOB
|
||||
export CONTAINER_CMD
|
||||
export SET_CONTAINER_CMD
|
||||
export ENTRYPOINT
|
||||
export EXEC_OPTS
|
||||
|
||||
export STACK_CORES = $(shell echo $(($(CPU_CORES)/2)))
|
||||
export BASE_PORTS
|
||||
export UNIWORXDB_OPTS ?= -cf
|
||||
export PROD ?= false
|
||||
export SRC
|
||||
|
||||
ifneq ($(PROD),true)
|
||||
export --DEVELOPMENT=--flag uniworx:dev
|
||||
endif
|
||||
|
||||
export DATE := $(shell date +'%Y-%m-%dT%H-%M-%S')
|
||||
|
||||
export CURR_DEV = $(shell cat develop/.current 2>/dev/null)
|
||||
export SET_DEVELOP = $(eval DEVELOP=develop/$$(CURR_DEV))
|
||||
export NEW_DEVELOP = $(eval DEVELOP=develop/$$(DATE))
|
||||
|
||||
|
||||
.PHONY: help
|
||||
# HELP: print out this help message
|
||||
help:
|
||||
docker compose run help
|
||||
@if [ -z "$$(which perl 2>/dev/null)" ] ; then \
|
||||
$(CONTAINER_FGRUN) .:/mnt 'debian:12.5' '/mnt/utils/makehelp.pl' '/mnt/Makefile' ; \
|
||||
else \
|
||||
utils/makehelp.pl Makefile ; \
|
||||
fi
|
||||
|
||||
.PHONY: clean
|
||||
# HELP: clean compilation caches
|
||||
# HELP: stop all running containers and remove all compilation results in the directory (but leave images including dependencies unharmed)
|
||||
clean:
|
||||
$(MAKE) clean-frontend CLEAN_DEPENDENCIES=$(CLEAN_DEPENDENCIES) CLEAN_IMAGES=$(CLEAN_IMAGES)
|
||||
$(MAKE) clean-backend CLEAN_DEPENDENCIES=$(CLEAN_DEPENDENCIES) CLEAN_IMAGES=$(CLEAN_IMAGES)
|
||||
rm -rf develop
|
||||
-rm -rf node_modules .npm .cache assets/icons assets/favicons static well-known config/manifest.json
|
||||
-rm -rf .stack-work .stack-work.lock
|
||||
-rm -rf bin .Dockerfile develop
|
||||
-$(CONTAINER_COMMAND) container prune --force
|
||||
.PHONY: clean-all
|
||||
# HELP: clean everything, including dependency and image caches
|
||||
clean-all: CLEAN_DEPENDENCIES = true
|
||||
clean-all: CLEAN_IMAGES = true
|
||||
clean-all: clean ;
|
||||
# HELP: like clean but with full container, image, and volume prune
|
||||
clean-all: clean
|
||||
-rm -rf .stack
|
||||
-$(CONTAINER_COMMAND) system prune --all --force --volumes
|
||||
-$(CONTAINER_COMMAND) image prune --all --force
|
||||
-$(CONTAINER_COMMAND) volume prune --force
|
||||
|
||||
.PHONY: clean-%
|
||||
# HELP(clean-$SERVICE): invalidate caches for a given service. Supported services: frontend, backend.
|
||||
clean-%:
|
||||
$(MAKE) stop-$*
|
||||
@$(MAKE) -- --clean-$*
|
||||
@echo "Cleaned $* build files and binaries."
|
||||
ifeq ("$(CLEAN_DEPENDENCIES)", "true")
|
||||
@$(MAKE) -- --clean-$*-deps
|
||||
@echo "Cleaned $* dependencies."
|
||||
endif
|
||||
ifeq ("$(CLEAN_IMAGES)", "true")
|
||||
$(MAKE) kill-$*
|
||||
docker compose rm --force --volumes
|
||||
docker compose down --rmi 'all' --volumes
|
||||
@echo "Cleaned $* image."
|
||||
endif
|
||||
--clean-frontend:
|
||||
-rm -rf assets/icons assets/favicons
|
||||
-rm -rf static well-known
|
||||
--clean-frontend-deps:
|
||||
-rm -rf frontend/node_modules
|
||||
-rm -rf frontend/.npm
|
||||
--clean-backend:
|
||||
-rm -rf backend/.stack-work
|
||||
-rm -rf bin/
|
||||
--clean-backend-deps:
|
||||
-rf -rf backend/.stack
|
||||
|
||||
|
||||
# TODO: only release when build and tests are passing!!!
|
||||
.PHONY: release
|
||||
# HELP: create, commit and push a new release
|
||||
release:
|
||||
VERSION=`./utils/version.pl -changelog CHANGELOG.md -v` ; \
|
||||
git add CHANGELOG.md ; \
|
||||
git commit -m "chore(release): $${VERSION}" ; \
|
||||
git push ; \
|
||||
git tag $${VERSION} ; \
|
||||
git push origin $${VERSION}
|
||||
./.gitlab-ci/version.pl -changelog CHANGELOG.md
|
||||
git add CHANGELOG.md
|
||||
VERSION=`.gitlab-ci/version.pl`
|
||||
git tag $${VERSION}
|
||||
git commit -m "chore(release): $${VERSION}"
|
||||
# git push
|
||||
|
||||
.PHONY: compile
|
||||
# HELP: perform full compilation (frontend and backend)
|
||||
compile: compile-frontend compile-backend ;
|
||||
.PHONY: compile-%
|
||||
# HELP(compile-$SERVICE): compile a given service once
|
||||
compile-%:
|
||||
docker compose run --remove-orphans --build --no-deps $* make compile
|
||||
compile:
|
||||
$(MAKE) compile-frontend
|
||||
$(MAKE) compile-backend
|
||||
|
||||
.PHONY: start
|
||||
# HELP: start complete development environment with a fresh test database
|
||||
start: start-postgres start-maildev start-memcached start-minio start-backend
|
||||
docker compose exec backend make start
|
||||
start:
|
||||
$(MAKE) start-postgres
|
||||
$(MAKE) start-memcached
|
||||
$(MAKE) start-minio
|
||||
$(MAKE) compile-frontend
|
||||
$(MAKE) start-backend
|
||||
|
||||
.PHONY: %-backend
|
||||
%-backend: SERVICE=backend
|
||||
%-backend: SERVICE_VARIANT=backend
|
||||
%-backend: CONTAINER_CMD=localhost/fradrive/backend
|
||||
%-backend: BASE_PORTS = "DEV_PORT_HTTP=3000" "DEV_PORT_HTTPS=3443"
|
||||
|
||||
.PHONY: %-uniworxdb
|
||||
%-uniworxdb: SERVICE=backend
|
||||
%-uniworxdb: SERVICE_VARIANT=uniworxdb
|
||||
%-uniworxdb: CONTAINER_CMD=localhost/fradrive/backend
|
||||
|
||||
.PHONY: %-ghci
|
||||
%-ghci: SERVICE=backend
|
||||
%-ghci: SERVICE_VARIANT=ghci
|
||||
%-ghci: CONTAINER_CMD=localhost/fradrive/backend
|
||||
|
||||
.PHONY: %-hoogle
|
||||
%-hoogle: SERVICE=backend
|
||||
%-hoogle: SERVICE_VARIANT=hoogle
|
||||
%-hoogle: BASE_PORTS = "HOOGLE_PORT=8081"
|
||||
%-hoogle: CONTAINER_CMD=localhost/fradrive/backend
|
||||
--start-hoogle:
|
||||
HOOGLE_PORT=`cat $(CONTAINER_FILE) | grep 'HOOGLE_PORT=' | sed 's/HOOGLE_PORT=//'` ; \
|
||||
stack $(STACK_CORES) hoogle -- server --local --port $${HOOGLE_PORT}
|
||||
|
||||
.PHONY: %-frontend
|
||||
%-frontend: SERVICE=frontend
|
||||
%-frontend: SERVICE_VARIANT=frontend
|
||||
%-frontend: CONTAINER_CMD=localhost/fradrive/frontend
|
||||
|
||||
.PHONY: %-postgres
|
||||
%-postgres: SERVICE=postgres
|
||||
%-postgres: SERVICE_VARIANT=postgres
|
||||
%-postgres: BASE_PORTS = "PGPORT=5432"
|
||||
%-postgres: CONTAINER_CMD=localhost/fradrive/postgres
|
||||
|
||||
.PHONY: %-memcached
|
||||
%-memcached: SERVICE=memcached
|
||||
%-memcached: SERVICE_VARIANT=memcached
|
||||
%-memcached: SET_CONTAINER_CMD=$$(MEMCACHED_IMAGE) --port=`cat $$(CONTAINER_FILE) | grep 'MEMCACHED_PORT=' | sed 's/MEMCACHED_PORT=//'`
|
||||
%-memcached: BASE_PORTS = "MEMCACHED_PORT=11211"
|
||||
|
||||
.PHONY: %-minio
|
||||
%-minio: SERVICE=minio
|
||||
%-minio: SERVICE_VARIANT=minio
|
||||
%-minio: SET_CONTAINER_CMD=$$(MINIO_IMAGE) -- server `mktemp` --address=:`cat $$(CONTAINER_FILE) | grep 'UPLOAD_S3_PORT=' | sed 's/UPLOAD_S3_PORT=//'`
|
||||
%-minio: BASE_PORTS = "UPLOAD_S3_PORT=9000"
|
||||
|
||||
.PHONY: start-%
|
||||
# HELP(start-$SERVICE): start a given service
|
||||
start-%:
|
||||
docker compose up -d --build $*
|
||||
start-%: JOB=start
|
||||
start-%: CF_PREFIX = start-
|
||||
start-%: CONTAINER_ATTACHED = false
|
||||
start-%: --act ;
|
||||
|
||||
.PHONY: compile-%
|
||||
compile-%: JOB=compile
|
||||
compile-%: CF_PREFIX = compile-
|
||||
compile-%: CONTAINER_ATTACHED = true
|
||||
compile-%: --act ;
|
||||
|
||||
.PHONY: dependencies-%
|
||||
dependencies-%: JOB=dependencies
|
||||
dependencies-%: CF_PREFIX = dependencies-
|
||||
dependencies-%: CONTAINER_ATTACHED = true
|
||||
dependencies-%: --act ;
|
||||
|
||||
.PHONY: test-%
|
||||
test-%: JOB=test
|
||||
test-%: CF_PREFIX = test-
|
||||
test-%: CONTAINER_ATTACHED = true
|
||||
test-%: --act ;
|
||||
|
||||
.PHONY: lint-%
|
||||
lint-%: JOB=lint
|
||||
lint-%: CF_PREFIX = lint-
|
||||
lint-%: CONTAINER_ATTACHED = true
|
||||
lint-%: --act ;
|
||||
|
||||
.PHONY: shell-%
|
||||
# HELP(shell-$SERVICE): launch a (bash) shell inside a given service
|
||||
shell-%:
|
||||
docker compose run --build --no-deps --entrypoint="$(ENTRYPOINT)" $*
|
||||
# HELP(shell-$SERVICE): launch (bash) shell inside a new $SERVICE container
|
||||
shell-%: JOB=shell
|
||||
shell-%: CF_PREFIX=shell-
|
||||
shell-%: CONTAINER_ATTACHED=true
|
||||
shell-%: --act ;
|
||||
.PHONY: ghci
|
||||
# HELP: launch ghci instance. Use in combination with SRC to specify the modules to be loaded by ghci: make ghci SRC=src/SomeModule.hs
|
||||
ghci: ENTRYPOINT=stack ghci $(SRC)
|
||||
ghci: shell-backend ;
|
||||
# HELP(ghci): launch new backend instance and enter interactive ghci shell
|
||||
ghci: shell-ghci;
|
||||
|
||||
.PHONY: stop
|
||||
# HELP: stop all services
|
||||
stop:
|
||||
docker compose down
|
||||
.PHONY: stop-%
|
||||
# HELP(stop-$SERVICE): stop a given service
|
||||
stop-%:
|
||||
docker compose down $*
|
||||
.PHONY: kill-%
|
||||
# HELP(kill-$SERVICE): kill a given service the hard way. Use this if the servive does not respond to stop.
|
||||
kill-%:
|
||||
docker compose kill $*
|
||||
--act: --develop_containerized;
|
||||
|
||||
--develop_%: PORTS = $(foreach PORT,$(BASE_PORTS),$(shell utils/next_free_port.pl $(PORT)))
|
||||
--develop_%: --ensure-develop
|
||||
DEVELOP=develop/`cat develop/.current` ; \
|
||||
CONTAINER_IDENT=$(CF_PREFIX)$(SERVICE_VARIANT) ; \
|
||||
CONTAINER_FILE=$${DEVELOP}/$${CONTAINER_IDENT} ; \
|
||||
if [[ -e $${CONTAINER_FILE} ]]; then \
|
||||
>&2 echo "Another $* service is already running! Use \"make new-develop\" to start a new develop instance despite currently running services." ; \
|
||||
exit 1 ; \
|
||||
fi ; \
|
||||
echo "$(PORTS)" | sed 's/ /\n/g' > $${CONTAINER_FILE} ; \
|
||||
$(MAKE) -- --$* CONTAINER_FILE=$${CONTAINER_FILE} CONTAINER_IDENT=$${CONTAINER_IDENT} JOB=$(JOB)
|
||||
|
||||
.PHONY: rebuild-%
|
||||
# HELP(rebuild-{backend,frontend,database,memcached,minio}): force-rebuild a given container image
|
||||
rebuild-%:
|
||||
$(MAKE) -- --image-build SERVICE=$* NO_CACHE=--no-cache
|
||||
--image-build:
|
||||
ifeq "$(CONTAINER_CMD)" "localhost/fradrive/$(SERVICE)"
|
||||
rm -f .Dockerfile
|
||||
ln -s docker/$(SERVICE)/Dockerfile .Dockerfile
|
||||
MOUNT_DIR=/mnt/fradrive; \
|
||||
PROJECT_DIR=/mnt/fradrive; \
|
||||
if [ "$(IN_CI)" == "true" ] ; then \
|
||||
PROJECT_DIR=/fradrive; \
|
||||
fi; \
|
||||
if [ "$(IN_CONTAINER)" == "false" ] ; then \
|
||||
$(CONTAINER_COMMAND) build $(NO_CACHE) \
|
||||
-v $(PWD):$${MOUNT_DIR} \
|
||||
--build-arg MOUNT_DIR=$(MOUNT_DIR) \
|
||||
--build-arg PROJECT_DIR=$${PROJECT_DIR} \
|
||||
--env IN_CONTAINER=true \
|
||||
--env JOB=$(JOB) \
|
||||
--tag fradrive/$(SERVICE) \
|
||||
--file $(PWD)/.Dockerfile ; \
|
||||
fi
|
||||
else
|
||||
:
|
||||
endif
|
||||
|
||||
--containerized: --image-build
|
||||
DEVELOP=`cat develop/.current` ; \
|
||||
./utils/watchcontainerrun.sh "$(CONTAINER_COMMAND)" "$(CONTAINER_FILE)" "$(CONTAINER_INIT)" "$(CONTAINER_CLEANUP)" & \
|
||||
CONTAINER_NAME=fradrive.$(CURR_DEV).$(CONTAINER_IDENT) ; \
|
||||
if ! [ -z "$(SET_CONTAINER_CMD)" ] ; \
|
||||
then \
|
||||
CONTAINER_CMD="$(SET_CONTAINER_CMD)" ; \
|
||||
else \
|
||||
CONTAINER_CMD=$(CONTAINER_CMD) ; \
|
||||
fi ; \
|
||||
CONTAINER_ID=`$(CONTAINER_BGRUN) \
|
||||
-v $(PWD):$(MOUNT_DIR) \
|
||||
--env IN_CONTAINER=true \
|
||||
--env FRADRIVE_MAKE_TARGET="--$(JOB)-$(SERVICE_VARIANT)" \
|
||||
--env CONTAINER_FILE=$(CONTAINER_FILE) \
|
||||
--env CONTAINER_NAME=$${CONTAINER_NAME} \
|
||||
--env JOB=$(JOB) \
|
||||
--env SRC=$(SRC) \
|
||||
--name $${CONTAINER_NAME} \
|
||||
$${CONTAINER_CMD} \
|
||||
` ; \
|
||||
printf "CONTAINER_ID=$${CONTAINER_ID}" >> "$(CONTAINER_FILE)" ; \
|
||||
if [[ "true" == "$(CONTAINER_ATTACHED)" ]] ; then \
|
||||
$(CONTAINER_COMMAND) attach $${CONTAINER_ID} || : ; \
|
||||
fi
|
||||
|
||||
# For Reverse Proxy Problem see: https://groups.google.com/g/yesodweb/c/2EO53kSOuy0/m/Lw6tq2VYat4J
|
||||
|
||||
# HELP(start-backend): start development instance
|
||||
--start-backend:
|
||||
export YESOD_IP_FROM_HEADER=true; \
|
||||
export DEV_PORT_HTTP=`cat $(CONTAINER_FILE) | grep 'DEV_PORT_HTTP=' | sed 's/DEV_PORT_HTTP=//'`; \
|
||||
export DEV_PORT_HTTPS=`cat $(CONTAINER_FILE) | grep 'DEV_PORT_HTTPS=' | sed 's/DEV_PORT_HTTPS=//'`; \
|
||||
export HOST=127.0.0.1 ; \
|
||||
export PORT=$${PORT:-$${DEV_PORT_HTTP}} ; \
|
||||
export DETAILED_LOGGING=$${DETAILED_LOGGING:-true} ; \
|
||||
export LOG_ALL=$${LOG_ALL:-false} ; \
|
||||
export LOGLEVEL=$${LOGLEVEL:-info} ; \
|
||||
export DUMMY_LOGIN=$${DUMMY_LOGIN:-true} ; \
|
||||
export SERVER_SESSION_ACID_FALLBACK=$${SERVER_SESSION_ACID_FALLBACK:-true} ; \
|
||||
export SERVER_SESSION_COOKIES_SECURE=$${SERVER_SESSION_COOKIES_SECURE:-false} ; \
|
||||
export COOKIES_SECURE=$${COOKIES_SECURE:-false} ; \
|
||||
export ALLOW_DEPRECATED=$${ALLOW_DEPRECATED:-true} ; \
|
||||
export ENCRYPT_ERRORS=$${ENCRYPT_ERRORS:-false} ; \
|
||||
export RIBBON=$${RIBBON:-$${HOST:-localhost}} ; \
|
||||
export APPROOT=$${APPROOT:-http://localhost:$${DEV_PORT_HTTP}} ; \
|
||||
export AVSPASS=$${AVSPASS:-nopasswordset} ; \
|
||||
stack $(STACK_CORES) exec --local-bin-path $$(pwd)/bin --copy-bins -- yesod devel -p "$${DEV_PORT_HTTP}" -q "$${DEV_PORT_HTTPS}"
|
||||
# HELP(compile-backend): compile backend binaries
|
||||
--compile-backend:
|
||||
stack build $(STACK_CORES) --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only $(--DEVELOPMENT) --local-bin-path $$(pwd)/bin --copy-bins
|
||||
# HELP(dependencies-backend): (re-)build backend dependencies
|
||||
--dependencies-backend: uniworx.cabal
|
||||
stack build $(STACK_CORES) --fast --only-dependencies
|
||||
# HELP(lint-backend): lint backend
|
||||
--lint-backend:
|
||||
stack build $(STACK_CORES) --test --fast --flag uniworx:library-only $(--DEVELOPMENT) uniworx:test:hlint
|
||||
# HELP(test-backend): test backend
|
||||
--test-backend:
|
||||
stack build $(STACK_CORES) --test --coverage --fast --flag uniworx:library-only $(--DEVELOPMENT)
|
||||
uniworx.cabal:
|
||||
stack exec -- hpack --force
|
||||
|
||||
# HELP(compile-frontend): compile frontend assets
|
||||
--compile-frontend: node_modules assets esbuild.config.mjs
|
||||
npm run build
|
||||
--start-frontend: --compile-frontend;
|
||||
--dependencies-frontend: node_modules assets static well-known;
|
||||
node_modules: package.json package-lock.json
|
||||
npm install --cache .npm --prefer-offline
|
||||
package-lock.json: package.json
|
||||
npm install --cache .npm --prefer-offline
|
||||
assets: assets/favicons assets/icons;
|
||||
assets/favicons:
|
||||
./utils/faviconize.pl assets/favicon.svg long assets/favicons
|
||||
assets/icons: node_modules assets/icons-src/fontawesome.json
|
||||
./utils/renamer.pl node_modules/@fortawesome/fontawesome-free/svgs/solid assets/icons-src/fontawesome.json assets/icons/fradrive
|
||||
./utils/renamer.pl node_modules/@fortawesome/fontawesome-free/svgs/regular assets/icons-src/fontawesome.json assets/icons/fradrive
|
||||
-cp assets/icons-src/*.svg assets/icons/fradrive
|
||||
static: node_modules assets esbuild.config.mjs
|
||||
npm run build
|
||||
well-known: static;
|
||||
|
||||
# HELP(compile-uniworxdb): clear and fill database. requires running postgres instance (use "make start-postgres" to start one)
|
||||
# TODO (db-m-$MIGRATION-backend): apply migration (see src/Model/Migration/Definition.hs for list of available migrations)
|
||||
--compile-uniworxdb: --compile-backend
|
||||
SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true} ; \
|
||||
AVSPASS=${AVSPASS:-nopasswordset} ; \
|
||||
./bin/uniworxdb $(UNIWORXDB_OPTS)
|
||||
|
||||
--shell-ghci:
|
||||
stack ghci -- $(SRC)
|
||||
# --main-is uniworx:exe:uniworx
|
||||
|
||||
# HELP(shell-{backend,frontend,memcached,minio,postgres}): enter (bash) shell inside a new container of a given service
|
||||
--shell-%:
|
||||
/bin/bash
|
||||
|
||||
# HELP(start-minio): start minio service
|
||||
|
||||
.PHONY: status
|
||||
# HELP: print an overview of currently running services and their health
|
||||
# HELP: print develop status: running containers, used ports
|
||||
status:
|
||||
docker compose ps
|
||||
.PHONY: top
|
||||
# HELP: print an overview of the ressource usage of the currently running services
|
||||
top:
|
||||
docker compose stats
|
||||
.PHONY: list-projects
|
||||
# HELP: list all currently running projects on this machine
|
||||
list-projects:
|
||||
docker compose ls
|
||||
@./utils/develop-status.pl -a
|
||||
|
||||
.PHONY: log-%
|
||||
# HELP(log-$SERVICE): follow the output of a given service. Service must be running.
|
||||
# HELP(log-$(JOB)-$(SERVICE)): inspect output of a given service. The service must be currently running When a service supports multiple running instances in one develop (i.e. backend), you need to specify the exact instance by its associated file (e.g. backend-1, backend-2, etc.), please check the contents of the develop/ directory for a list of running instances.
|
||||
log-%:
|
||||
docker compose logs --follow --timestamps $*
|
||||
DEVELOP=develop/`cat develop/.current` ; \
|
||||
SEARCH_FILE="$${DEVELOP}/$*" ; \
|
||||
if [[ ! -e "$${SEARCH_FILE}" ]] ; then \
|
||||
SEARCH_FILE="$${DEVELOP}/.exited.$*" ; \
|
||||
fi ; \
|
||||
if [[ -e "$${SEARCH_FILE}" ]] ; then \
|
||||
$(CONTAINER_COMMAND) logs --follow `cat "$${SEARCH_FILE}" | grep CONTAINER_ID= | sed 's/^CONTAINER_ID=//'` ; \
|
||||
else \
|
||||
>&2 echo "Cannot show log: No develop file found for '$*'" ; \
|
||||
exit 1 ; \
|
||||
fi
|
||||
|
||||
.PHONY: enter
|
||||
# HELP: launch (bash) shell inside a currently running container. Use ./enter shell wrapper for more convenient usage, possibly with tab-completion in the future
|
||||
enter: --ensure-develop
|
||||
$(MAKE) -- --enter
|
||||
|
||||
.PHONY: psql
|
||||
# HELP: enter psql (postgresql) cli inside a currently running database container
|
||||
psql: ENTRYPOINT=/usr/bin/psql -d uniworx
|
||||
psql: EXEC_OPTS=--user postgres
|
||||
psql: --ensure-develop
|
||||
$(MAKE) -- --enter CONTAINER_FILE=develop/`cat develop/.current`/start-postgres
|
||||
|
||||
--enter:
|
||||
CONTAINER_ID=`cat $(CONTAINER_FILE) | grep 'CONTAINER_ID=' | sed 's/CONTAINER_ID=//'` ; \
|
||||
$(CONTAINER_COMMAND) exec -it $(EXEC_OPTS) $${CONTAINER_ID} $(if $(ENTRYPOINT),$(ENTRYPOINT),/bin/bash)
|
||||
|
||||
.PHONY: stop
|
||||
# HELP: stop all currently running develop instances
|
||||
stop:
|
||||
rm -rf develop
|
||||
.PHONY: stop-%
|
||||
# HELP(stop-SERVICE): stop all currently running develop instances of a given service (i.e. backend,frontend,uniworxdb,hoogle,postgres,...)
|
||||
# HELP(stop-JOB): stop all currently running develop instances of a given job (i.e. compile,start,test,lint)
|
||||
stop-compile: CF_PREFIX=compile-
|
||||
stop-start: CF_PREFIX=start-
|
||||
stop-test: CF_PREFIX=test-
|
||||
stop-lint: CF_PREFIX=lint-
|
||||
stop-%: --stop;
|
||||
--stop:
|
||||
$(SET_DEVELOP)
|
||||
ifdef CF_PREFIX
|
||||
rm -rf $(DEVELOP)/$(CF_PREFIX)*
|
||||
endif
|
||||
ifdef SERVICE_VARIANT
|
||||
rm -rf $(DEVELOP)/*-$(SERVICE_VARIANT)
|
||||
endif
|
||||
|
||||
.PHONY: new-develop
|
||||
# HELP: instantiate new development bundle, i.e. create new directory under develop/
|
||||
new-develop:
|
||||
$(NEW_DEVELOP)
|
||||
mkdir -p $(DEVELOP)
|
||||
$(MAKE) develop/.current
|
||||
.PHONY: switch-develop
|
||||
# HELP: switch current develop instance to DEVELOP=...
|
||||
switch-develop:
|
||||
if ! [ -e develop/$(DEVELOP) ]; then \
|
||||
echo "Specified develop $(DEVELOP) does not exist! Not switching." ; \
|
||||
exit 1 ; \
|
||||
fi ; \
|
||||
echo "$(DEVELOP)" > develop/.current
|
||||
--ensure-develop:
|
||||
if ! [[ -e develop ]]; then \
|
||||
$(MAKE) new-develop; \
|
||||
fi
|
||||
$(MAKE) develop/.current
|
||||
$(SET_DEVELOP)
|
||||
.PHONY: develop/.current
|
||||
develop/.current:
|
||||
ls -1 develop | tail -n1 > develop/.current
|
||||
|
||||
.PHONY: --%
|
||||
.SUFFIXES: # Delete all default suffixes
|
||||
|
||||
@ -29,7 +29,6 @@
|
||||
"file-upload": "file-arrow-up",
|
||||
"file-zip": "file-zipper",
|
||||
"file-csv": "file-csv",
|
||||
"file-missing": "file-circle-minus",
|
||||
"sft-question": "circle-question",
|
||||
"sft-hint": "life-ring",
|
||||
"sft-solution": "circle-exclamation",
|
||||
@ -77,13 +76,12 @@
|
||||
"submission-no-users": "user-slash",
|
||||
"reset": "arrow-rotate-left",
|
||||
"blocked": "ban",
|
||||
"certificate": "car-side",
|
||||
"certificate": "certificate",
|
||||
"print-center": "envelopes-bulk",
|
||||
"letter": "envelopes-bulk",
|
||||
"at": "at",
|
||||
"supervisor": "person",
|
||||
"supervisor-foreign": "person-rays",
|
||||
"superior": "user-tie",
|
||||
"waiting-for-user": "user-gear",
|
||||
"expired": "hourglass-end",
|
||||
"locked": "lock",
|
||||
@ -91,18 +89,9 @@
|
||||
"trash": "trash",
|
||||
"reset-tries": "trash-can-arrow-up",
|
||||
"company": "building",
|
||||
"company-warning": "building-circle-exclamation",
|
||||
"edit": "pen-to-square",
|
||||
"user-edit": "user-pen",
|
||||
"loading": "spinner",
|
||||
"placeholder": "notdef",
|
||||
"reroute": "diamond-turn-right",
|
||||
"top": "award",
|
||||
"wildcard": "asterisk",
|
||||
"user-unknown": "user-slash",
|
||||
"user-badge": "id-badge",
|
||||
"glasses": "glasses",
|
||||
"missing": "question",
|
||||
"pin-protect": "key"
|
||||
"placeholder": "notdef"
|
||||
}
|
||||
|
||||
|
||||
234
azure-pipelines.yaml
Executable file → Normal file
234
azure-pipelines.yaml
Executable file → Normal file
@ -1,197 +1,47 @@
|
||||
# SPDX-FileCopyrightText: 2024-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
trigger:
|
||||
branches:
|
||||
include:
|
||||
- '*'
|
||||
tags:
|
||||
include:
|
||||
- '*'
|
||||
#paths:
|
||||
# exclude:
|
||||
# - CHANGELOG.md
|
||||
|
||||
parameters:
|
||||
- name: services
|
||||
type: object
|
||||
default:
|
||||
- name: frontend
|
||||
imageBase:
|
||||
image: devfra.azurecr.io/de.fraport.build/npm
|
||||
tag: node-20
|
||||
# extraBuildOptions: |
|
||||
# --build-arg NPM_CUSTOM_REGISTRY=https://pkgs.dev.azure.com/fraport/_packaging/packages/npm/registry/
|
||||
dependsOn: []
|
||||
dependenciesCaches:
|
||||
- key: package.json | package-lock.json
|
||||
path: node_modules/
|
||||
- key: package.json | package-lock.json
|
||||
path: .npm/
|
||||
- key: package.json | esbuild.config.mjs | utils/renamer.pl | utils/faviconize.pl | frontend/src/icons.scss
|
||||
path: assets/icons/
|
||||
- key: package.json | esbuild.config.mjs | utils/renamer.pl | utils/faviconize.pl | frontend/src/icons.scss
|
||||
path: assets/favicons/
|
||||
buildPool: 'Prod Private Agent Pool'
|
||||
buildCores: 1
|
||||
buildTimeout: 60
|
||||
buildArtifacts: |
|
||||
assets/icons/fradrive/*.svg
|
||||
assets/favicons/*.png
|
||||
assets/favicons/include.html
|
||||
frontend/src/env.sass
|
||||
config/manifest.json
|
||||
static/**/*
|
||||
well-known/**/*
|
||||
- name: backend
|
||||
imageBase:
|
||||
image: devfra.azurecr.io/de.fraport.build/haskell
|
||||
tag: 8.10.4
|
||||
dependsOn:
|
||||
- Build_frontend
|
||||
dependenciesCaches:
|
||||
- key: stack.yaml | stack.yaml.lock
|
||||
path: .stack/
|
||||
buildPool: 'Prod Private Agent Pool DS3'
|
||||
buildCores: 3
|
||||
buildTimeout: 1440
|
||||
buildArtifacts: |
|
||||
bin/*
|
||||
|
||||
variables:
|
||||
buildImageUpstream: devfra.azurecr.io/de.fraport.fradrive.build
|
||||
setupImages: $[ or( eq(variables.forcePushLatest, true), eq(variables['Build.SourceBranch'], 'refs/heads/master'), startsWith(variables['Build.SourceBranch'], 'refs/heads/update'), startsWith(variables['Build.SourceBranch'], 'refs/tags/') ) ]
|
||||
|
||||
pool: 'Prod Private Agent Pool'
|
||||
|
||||
stages:
|
||||
|
||||
- stage: Setup
|
||||
jobs:
|
||||
- ${{ each service in parameters.services }}:
|
||||
- template: .azure-pipelines/templates/jobs/setup_image.yaml
|
||||
parameters:
|
||||
imageName: ${{service.name}}
|
||||
imageBase: ${{service.imageBase}}
|
||||
- template: .azure-pipelines/templates/jobs/setup_dependencies.yaml
|
||||
parameters:
|
||||
serviceName: ${{service.name}}
|
||||
dependenciesCaches: ${{service.dependenciesCaches}}
|
||||
dependenciesBuildPool: ${{service.buildPool}}
|
||||
dependenciesBuildCores: ${{service.buildCores}}
|
||||
dependenciesBuildTimeout: ${{service.buildTimeout}}
|
||||
|
||||
- stage: Build
|
||||
dependsOn: Setup
|
||||
jobs:
|
||||
- ${{ each service in parameters.services }}:
|
||||
- job: Build_${{service.name}}
|
||||
displayName: Compile ${{service.name}}
|
||||
dependsOn: ${{service.dependsOn}}
|
||||
pool: '${{service.buildPool}}'
|
||||
timeoutInMinutes: ${{service.buildTimeout}}
|
||||
container:
|
||||
${{ if eq(variables.setupImages, true) }}:
|
||||
image: $(buildImageUpstream)/${{service.name}}:$(Build.BuildNumber)
|
||||
${{ else }}:
|
||||
image: $(buildImageUpstream)/${{service.name}}:latest
|
||||
endpoint: devfra
|
||||
env:
|
||||
PROJECT_DIR: $(Build.Repository.LocalPath)
|
||||
IN_CONTAINER: true
|
||||
IN_CI: true
|
||||
steps:
|
||||
- ${{ each dependencyCache in service.dependenciesCaches }}:
|
||||
- template: .azure-pipelines/templates/steps/cache.yaml
|
||||
parameters:
|
||||
cacheIdent: '${{service.name}}-dependencies'
|
||||
cacheKeys: '${{dependencyCache.key}}'
|
||||
cachePath: '${{dependencyCache.path}}'
|
||||
- ${{ each dependency in service.dependsOn }}:
|
||||
- template: .azure-pipelines/templates/steps/artifact-download.yaml
|
||||
parameters:
|
||||
artifactName: '${{dependency}}'
|
||||
- template: .azure-pipelines/templates/steps/make.yaml
|
||||
parameters:
|
||||
makeJob: compile
|
||||
makeService: ${{service.name}}
|
||||
makeVars: 'CPU_CORES=${{service.buildCores}} STACK_CORES=-j${{service.buildCores}}'
|
||||
- task: CopyFiles@2
|
||||
displayName: Prepare ${{service.name}} build artifacts for upload
|
||||
inputs:
|
||||
Contents: '${{service.buildArtifacts}}'
|
||||
TargetFolder: '$(Build.ArtifactStagingDirectory)'
|
||||
- task: PublishBuildArtifacts@1
|
||||
displayName: Publish ${{service.name}} build artifacts
|
||||
inputs:
|
||||
PathtoPublish: '$(Build.ArtifactStagingDirectory)'
|
||||
ArtifactName: 'Build_${{service.name}}'
|
||||
publishLocation: 'Container'
|
||||
|
||||
# - stage: Test
|
||||
# dependsOn: Build
|
||||
# condition: eq(variables.skipTests, false)
|
||||
# jobs:
|
||||
# - ${{ each service in parameters.services }}:
|
||||
# - job: Test_${{service.name}}
|
||||
# displayName: Run ${{service.name}} tests
|
||||
# pool: '${{service.buildPool}}'
|
||||
# timeoutInMinutes: ${{service.buildTimeout}}
|
||||
# container:
|
||||
# # TODO: do not use latest on update branches
|
||||
# image: $(buildImageUpstream)/${{service.name}}:latest
|
||||
# endpoint: devfra
|
||||
# env:
|
||||
# PROJECT_DIR: $(Build.Repository.LocalPath)
|
||||
# IN_CONTAINER: true
|
||||
# IN_CI: true
|
||||
# steps:
|
||||
# - ${{ each dependencyCache in service.dependenciesCaches }}:
|
||||
# - template: .azure-pipelines/templates/steps/cache.yaml
|
||||
# parameters:
|
||||
# cacheIdent: '${{service.name}}-dependencies'
|
||||
# cacheKeys: '${{dependencyCache.key}}'
|
||||
# cachePath: '${{dependencyCache.path}}'
|
||||
# - ${{ each dependency in service.dependsOn }}:
|
||||
# - template: .azure-pipelines/templates/steps/artifact-download.yaml
|
||||
# parameters:
|
||||
# artifactName: '${{dependency}}'
|
||||
# - task: Docker@2
|
||||
# displayName: Login to container registry
|
||||
# inputs:
|
||||
# command: login
|
||||
# containerRegistry: devfra
|
||||
# - task: Bash@3
|
||||
# displayName: Start database container for testing
|
||||
# inputs:
|
||||
# targetType: inline
|
||||
# script: |
|
||||
# docker run -d devfra.azurecr.io/de.fraport.trusted/postgres:16.1-bookworm
|
||||
# - template: .azure-pipelines/templates/steps/make.yaml
|
||||
# parameters:
|
||||
# makeJob: lint
|
||||
# makeService: ${{service.name}}
|
||||
# makeVars: 'CPU_CORES=${{service.buildCores}} STACK_CORES=-j${{service.buildCores}}'
|
||||
# - template: .azure-pipelines/templates/steps/make.yaml
|
||||
# parameters:
|
||||
# makeJob: test
|
||||
# makeService: ${{service.name}}
|
||||
# makeVars: 'CPU_CORES=${{service.buildCores}} STACK_CORES=-j${{service.buildCores}}'
|
||||
# - task: Docker@2
|
||||
# displayName: Logout from container registry
|
||||
# inputs:
|
||||
# command: logout
|
||||
# containerRegistry: devfra
|
||||
# - job: TestReport_${{service.name}}
|
||||
# displayName: Upload test reports for ${{service.name}}
|
||||
# steps:
|
||||
# - script: echo "Work in progress" # TODO
|
||||
|
||||
- stage: Release
|
||||
dependsOn: Build # TODO Test
|
||||
condition: or(eq(variables.forceRelease, true), startsWith(variables['Build.SourceBranch'], 'refs/tags/'))
|
||||
jobs:
|
||||
- template: .azure-pipelines/templates/jobs/release.yaml
|
||||
parameters:
|
||||
releaseTag: ${{split(variables['Build.SourceBranch'], '/')[2]}}
|
||||
jobs:
|
||||
- job: BuildImages
|
||||
container:
|
||||
image: devfra.azurecr.io/de.fraport.build/tools:1.1.0
|
||||
endpoint: devfra
|
||||
steps:
|
||||
- task: Docker@2
|
||||
name: dockerLoginDevFra
|
||||
displayName: Docker Login to devfra
|
||||
inputs:
|
||||
command: login
|
||||
containerRegistry: devFra
|
||||
- task: Docker@2
|
||||
name: dockerBuild
|
||||
displayName: Backend image build
|
||||
inputs:
|
||||
command: build
|
||||
Dockerfile: docker/haskell/Dockerfile
|
||||
buildContext: .
|
||||
tags: |
|
||||
$(Build.BuildNumber)
|
||||
arguments: |
|
||||
--build-arg HTTPS_PROXY=http://proxy.frankfurt-airport.de:8080
|
||||
--build-arg HTTP_PROXY=http://proxy.frankfurt-airport.de:8080
|
||||
--build-arg NO_PROXY='localhost,127.0.0.1,*.docker.internal,*.azmk8s.io,devfra.azurecr.io,devfra.westeurope.data.azurecr.io'
|
||||
- task: Docker@2
|
||||
name: dockerPush
|
||||
displayName: Backend image push
|
||||
inputs:
|
||||
command: push
|
||||
repository: $(imageRepository)
|
||||
Dockerfile: docker/haskell/Dockerfile
|
||||
buildContext: .
|
||||
tags: |
|
||||
$(Build.BuildNumber)
|
||||
- task: Docker@2
|
||||
name: dockerLogoutDevFra
|
||||
displayName: Docker Logout from devfra
|
||||
inputs:
|
||||
command: logout
|
||||
containerRegistry: devFra
|
||||
@ -1,40 +0,0 @@
|
||||
ARG FROM_IMG=docker.io/library/debian
|
||||
ARG FROM_TAG=12.5
|
||||
|
||||
FROM ${FROM_IMG}:${FROM_TAG}
|
||||
|
||||
ENV LANG=de_DE.UTF-8
|
||||
|
||||
# basic dependencies
|
||||
RUN apt-get -y update && apt-get -y install git
|
||||
RUN apt-get -y update && apt-get -y install haskell-stack
|
||||
RUN apt-get -y update && apt-get -y install llvm
|
||||
RUN apt-get -y update && apt-get install -y --no-install-recommends locales locales-all
|
||||
|
||||
# compile-time dependencies
|
||||
RUN apt-get -y update && apt-get install -y libpq-dev libsodium-dev
|
||||
RUN apt-get -y update && apt-get -y install g++ libghc-zlib-dev libpq-dev libsodium-dev pkg-config
|
||||
RUN apt-get -y update && DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends tzdata
|
||||
|
||||
# run-time dependencies for uniworx binary
|
||||
RUN apt-get -y update && apt-get -y install fonts-roboto
|
||||
# RUN apt-get -y update && apt-get -y install pdftk
|
||||
# RUN apt-get -y update && apt-get -y install \
|
||||
# texlive texlive-latex-recommended texlive-luatex texlive-plain-generic texlive-lang-german texlive-lang-english
|
||||
RUN apt-get -y update && apt-get -y install texlive
|
||||
# RUN ls /usr/local/texlive
|
||||
# RUN chown -hR root /usr/local/texlive/2018
|
||||
# RUN tlmgr init-usertree
|
||||
# RUN tlmgr option repository ftp://tug.org/historic/systems/texlive/2018/tlnet-final
|
||||
# RUN tlmgr update --self --all
|
||||
|
||||
ARG PROJECT_DIR=/fradrive
|
||||
ENV PROJECT_DIR=${PROJECT_DIR}
|
||||
# RUN mkdir -p "${PROJECT_DIR}"; chmod -R 777 "${PROJECT_DIR}"
|
||||
WORKDIR ${PROJECT_DIR}
|
||||
ENV HOME=${PROJECT_DIR}
|
||||
ENV STACK_ROOT="${PROJECT_DIR}/.stack"
|
||||
|
||||
ENV STACK_SRC=""
|
||||
ENV STACK_ENTRY="ghci ${STACK_SRC}"
|
||||
ENTRYPOINT stack ${STACK_ENTRY}
|
||||
@ -1,51 +0,0 @@
|
||||
export CPU_CORES = $(shell cat /proc/cpuinfo | grep '^processor' | wc -l)
|
||||
export STACK_CORES = $(shell echo $(($(CPU_CORES)/2)))
|
||||
|
||||
ifeq ($(PROD),true)
|
||||
export --DEVELOPMENT=--flag uniworx:-dev
|
||||
else
|
||||
export --DEVELOPMENT=--flag uniworx:dev
|
||||
endif
|
||||
|
||||
.PHONY: dependencies
|
||||
dependencies:
|
||||
stack install hpack; stack install yesod-bin; \
|
||||
stack build -j2 --only-dependencies
|
||||
|
||||
.PHONY: compile
|
||||
compile: dependencies
|
||||
stack build $(STACK_CORES) --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only $(--DEVELOPMENT) --local-bin-path $$(pwd)/bin --copy-bins
|
||||
|
||||
.PHONY: lint
|
||||
lint:
|
||||
stack build $(STACK_CORES) --test --fast --flag uniworx:library-only $(--DEVELOPMENT) uniworx:test:hlint
|
||||
|
||||
.PHONY: test
|
||||
test:
|
||||
stack build $(STACK_CORES) --test --coverage --fast --flag uniworx:library-only $(--DEVELOPMENT)
|
||||
|
||||
# For Reverse Proxy Problem see: https://groups.google.com/g/yesodweb/c/2EO53kSOuy0/m/Lw6tq2VYat4J
|
||||
.PHONY: start
|
||||
start: dependencies
|
||||
export YESOD_IP_FROM_HEADER=true; \
|
||||
export DEV_PORT_HTTP=3000; \
|
||||
export DEV_PORT_HTTPS=3443; \
|
||||
export HOST=127.0.0.1 ; \
|
||||
export PORT=$${PORT:-$${DEV_PORT_HTTP}} ; \
|
||||
export DETAILED_LOGGING=$${DETAILED_LOGGING:-true} ; \
|
||||
export LOG_ALL=$${LOG_ALL:-false} ; \
|
||||
export LOGLEVEL=$${LOGLEVEL:-info} ; \
|
||||
export DUMMY_LOGIN=$${DUMMY_LOGIN:-true} ; \
|
||||
export SERVER_SESSION_ACID_FALLBACK=$${SERVER_SESSION_ACID_FALLBACK:-true} ; \
|
||||
export SERVER_SESSION_COOKIES_SECURE=$${SERVER_SESSION_COOKIES_SECURE:-false} ; \
|
||||
export COOKIES_SECURE=$${COOKIES_SECURE:-false} ; \
|
||||
export ALLOW_DEPRECATED=$${ALLOW_DEPRECATED:-true} ; \
|
||||
export ENCRYPT_ERRORS=$${ENCRYPT_ERRORS:-false} ; \
|
||||
export RIBBON=$${RIBBON:-$${HOST:-localhost}} ; \
|
||||
export APPROOT=$${APPROOT:-http://localhost:$${DEV_PORT_HTTP}} ; \
|
||||
export AVSPASS=$${AVSPASS:-nopasswordset} ; \
|
||||
stack $(STACK_CORES) exec --local-bin-path $$(pwd)/bin --copy-bins -- yesod devel -p "$${DEV_PORT_HTTP}" -q "$${DEV_PORT_HTTPS}"
|
||||
|
||||
.PHONY: clean
|
||||
clean:
|
||||
rm -rf .stack-work .stack uniworx.cabal .ghc
|
||||
@ -1,32 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
|
||||
# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
|
||||
# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
|
||||
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
|
||||
|
||||
|
||||
# DEVELOPMENT ONLY, NOT TO BE USED IN PRODUCTION
|
||||
|
||||
avs-licence-synch:
|
||||
times: [12]
|
||||
level: 4
|
||||
reason-filter: "(firm|block)"
|
||||
max-changes: 999
|
||||
|
||||
mail-reroute-to:
|
||||
name: "FRADrive-QA-Umleitungen"
|
||||
email: "FRADrive-TEST-Umleitungen@fraport.de"
|
||||
|
||||
# Enqueue at specified hour, a few minutes later
|
||||
job-lms-qualifications-enqueue-hour: 16
|
||||
job-lms-qualifications-dequeue-hour: 4
|
||||
|
||||
# Using these setting kills the job-workers somehow
|
||||
# job-workers: 5
|
||||
# job-flush-interval: 600
|
||||
# job-stale-threshold: 3600
|
||||
# job-move-threshold: 60
|
||||
|
||||
@ -1,68 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
AvsPersonInfo: AVS person info
|
||||
AvsPersonId: AVS person id
|
||||
AvsPersonNo: AVS person number
|
||||
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
|
||||
AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
|
||||
AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
|
||||
AvsCardNo: Card number
|
||||
AvsFirstName: First name
|
||||
AvsLastName: Last name
|
||||
AvsPrimaryCompany: Primary company
|
||||
AvsInternalPersonalNo: Personnel number (Fraport AG only)
|
||||
AvsVersionNo: Version number
|
||||
AvsQueryNeeded: AVS connection required.
|
||||
AvsQueryEmpty: At least one query field must be filled!
|
||||
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
|
||||
AvsLicence: Driving Licence
|
||||
|
||||
AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
|
||||
BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
|
||||
BtnAvsImportUnknown: Import AVS data for unknown persons
|
||||
AvsRevokeFor n@Int: Are you sure to immediately revoke all apron driving licences for #{n} unknown #{pluralENs n "driver"}?
|
||||
AvsImportIDs n m: AVS person data imported: #{show n}/#{show m}
|
||||
AvsImportAmbiguous n@Int: Import failed for #{show n} ambiguous AVS Ids
|
||||
AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids
|
||||
AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m}
|
||||
SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users
|
||||
RevokeFraDriveLicencesError alic@AvsLicence: Revoking licences _{alic} failed entirely
|
||||
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{show n} drivers
|
||||
RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
|
||||
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
|
||||
AvsCommunicationError: AVS interface returned an unexpected error.
|
||||
AvsCommunicationTimeout: AVS interface returned no response within timeout limit.
|
||||
LicenceTableChangeAvs: Change in AVS
|
||||
LicenceTableGrantFDrive: Grant in FRADrive
|
||||
LicenceTableRevokeFDrive: Revoke in FRADrive
|
||||
TableAvsActiveCards: Valid Cards
|
||||
TableAvsCardValid: Currently valid
|
||||
TableAvsCardIssueDate: Issued
|
||||
TableAvsCardValidTo: Valid to
|
||||
AvsCardAreas: Card areas
|
||||
AvsCardColor: Color
|
||||
AvsCardColorGreen: Green
|
||||
AvsCardColorBlue: Blue
|
||||
AvsCardColorRed: Red
|
||||
AvsCardColorYellow: Yellow
|
||||
LastAvsSynchronisation: Last AVS synchronisation
|
||||
LastAvsSyncedBefore: Last AVS synchronisation before
|
||||
LastAvsSynchError: Last AVS Error
|
||||
|
||||
AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond
|
||||
AvsUserUnassociated user: AVS id unknown for user #{user}
|
||||
AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known)
|
||||
AvsUserAmbiguous api: Multiple matching users found for #{tshow api}
|
||||
AvsStatusSearchEmpty: AVS returned no card information
|
||||
AvsPersonSearchEmpty: AVS search returned empty result
|
||||
AvsPersonSearchAmbiguous: AVS search returned more than one result
|
||||
AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
|
||||
AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead
|
||||
AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique
|
||||
AvsCardsEmpty: AVS search returned no id cards
|
||||
AvsCurrentData: All shown data has been recently received via the AVS interface.
|
||||
AvsUpdateDayCheck: In addition, a background AVS update has been scheduled for all persons occrring within the day agenda (once per Day).
|
||||
|
||||
AvsNoApronCard: No valid card granting apron access found
|
||||
AvsNoCompanyCard mcn@(Maybe CompanyName): No valid card for booking company #{maybeEmpty mcn ciOriginal} found
|
||||
@ -1,38 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
MaterialList: Material
|
||||
MaterialName: Name
|
||||
MaterialType: Type
|
||||
MaterialTypePlaceholder: Slides, Code, Example, ...
|
||||
MaterialTypeSlides: Slides
|
||||
MaterialTypeCode: Code
|
||||
MaterialTypeExample: Example
|
||||
MaterialDescription: Description
|
||||
MaterialVisibleFrom: Visible to participants from
|
||||
MaterialVisibleFromTip: Never visible to participants if left empty; leaving the date empty is only sensible for unfinished course category material or when course category material should be provided only to sheet correctors
|
||||
MaterialVisibleFromEditWarning: This course category material has already been published and should not be edited. Doing so might confuse the participants.
|
||||
MaterialInvisible: This course category material is currently invisible to participants!
|
||||
MaterialFiles: Files
|
||||
MaterialHeading materialName: #{materialName}
|
||||
MaterialListHeading: Course category materials
|
||||
MaterialNewHeading: Publish new course category material
|
||||
MaterialNewTitle: New course category material
|
||||
MaterialEditHeading materialName: Edit course category material “#{materialName}”
|
||||
MaterialEditTitle materialName: Edit course category material “#{materialName}”
|
||||
MaterialSaveOk tid ssh csh materialName: Successfully saved “#{materialName}” for course category #{tid}-#{ssh}-#{csh}
|
||||
MaterialNameDup tid ssh csh materialName: Course category material with the name “#{materialName}” already exists for course category #{tid}-#{ssh}-#{csh}
|
||||
MaterialDeleteCaption: Do you really want to delete the course category material mentioned below?
|
||||
MaterialDelHasFiles count: including #{count} #{pluralEN count "file" "files"}
|
||||
MaterialIsVisible: Caution, this course category material has already been published.
|
||||
MaterialDeleted materialName: Successfully deleted course category material “#{materialName}”
|
||||
MaterialArchiveName tid ssh csh materialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName}
|
||||
MaterialVideo materialName: #{materialName} - Video
|
||||
MaterialVideoUnsupported: Your browser does not seem to support embedded video
|
||||
MaterialVideoDownload: Download
|
||||
MaterialFree: Course category material is publicly available.
|
||||
AccessibleSince: Accessible since
|
||||
VisibleFrom: Published
|
||||
FilterMaterialNameSearch !ident-ok: Name
|
||||
FilterMaterialTypeAndDescriptionSearch: Type/description
|
||||
@ -1,97 +0,0 @@
|
||||
# SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
FirmSuperDefault: Default supervisor
|
||||
FirmSuperForeign: External supervisor
|
||||
FirmSuperIrregular: Irregular supervisor
|
||||
FirmAssociates: Company associated users
|
||||
FirmContact: Company Contact
|
||||
FirmEmail: General company email
|
||||
FirmAddress: Postal address
|
||||
FirmDefaultPreferenceInfo: Default setting for new company associates only
|
||||
FirmAction: Companywide action
|
||||
FirmActionInfo: Affects alle company associates under your supervision.
|
||||
FirmActNotify: Send message
|
||||
FirmActResetSupervision: Reset supervisors for all company associates
|
||||
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
|
||||
FirmActRemoveSupers: Terminate all company related supervisionships?
|
||||
FirmActResetMutualSupervision: Supervisors supervise each other
|
||||
FirmActResetSupersKeepAll: Keep all
|
||||
FirmActResetSupersRemoveAps: Remove default supervisors only
|
||||
FirmActResetSupersRemoveAll: Remove all
|
||||
FirmActAddSupervisors: Add supervisors
|
||||
FirmActAddAssociates: Associate users with company
|
||||
FirmActAddSupersEmpty: No new supervisors added!
|
||||
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
|
||||
FirmActAddAssocsEmpty: No new company associated users added!
|
||||
FirmActAddAssocs n: #{pluralENsN n "company associated user"} added.
|
||||
RemoveSupervisors ndef: #{ndef} default supervisors removed.
|
||||
FirmActChangeContactUser: Change contact data for all company associates
|
||||
FirmActChangeContactFirm: Change company contact data
|
||||
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
|
||||
FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only
|
||||
FirmUserActNotify: Send message
|
||||
FirmUserActResetSupervision: Reset supervisors to company default
|
||||
FirmUserActSetSupervisor: Change supervision
|
||||
FirmUserActChangeContact: Change contact data for selected company associates
|
||||
FirmUserActChangeDetails: Edit company association
|
||||
FirmUserActRemove: Delete company association
|
||||
FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
|
||||
FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
|
||||
FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted.
|
||||
FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
|
||||
FirmNewSupervisor: Appoint new individual supervisors
|
||||
FirmSetSupervisor: Add existing supervisors
|
||||
FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||
FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
|
||||
FirmSuperActNotify: Send message
|
||||
FirmSuperActSwitchSuper: Change default company supervisor
|
||||
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
|
||||
FirmSuperActRMSuperDef: Remove default supervisor
|
||||
FirmSuperActRMSuperActive: Terminate active supervisions within this company?
|
||||
FirmsNotification: Send company notification e-mail
|
||||
FirmNotification fsh: Send e-mail to #{fsh}
|
||||
FirmsNotificationTitle: Company notification
|
||||
FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification
|
||||
FilterSupervisor: Has active supervisor
|
||||
FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
|
||||
FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
|
||||
FilterForeignSupervisor: Has company-external supervisors
|
||||
FilterIsForeignSupervisee: Supervisor for company external users
|
||||
FilterFirmExtern: External company
|
||||
FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
|
||||
FilterFirmPrimary: Is primary company in FRADrive
|
||||
FilterHasQualification: Has company associates with currently valid qualification
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
|
||||
FirmSupervisorIndependent: Independent supervisors
|
||||
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
|
||||
NoCompanySelected: Select at least one company, please.
|
||||
TableIsDefaultSupervisor: Default supervisor
|
||||
TableSuperior: Superior
|
||||
TableIsDefaultReroute: Default reroute
|
||||
FormFieldPostal: Notification type
|
||||
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
|
||||
FormFieldPinPass: Protect sensitive PDF e-mail attachments by password?
|
||||
FormFieldPinPassRemove: Remove password protection for PDF e-mail attachments?
|
||||
FirmSupervisionKeyData: Supervision key data
|
||||
CompanyUserPriority: Company priority
|
||||
CompanyUserPriorityTip: Company priority is relative to other company associations for a user
|
||||
CompanyUserUseCompanyAddress: Use company postal address
|
||||
CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
|
||||
CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
|
||||
CompanySupervisorCompanyMissing fsh: Receiver is not associated with #{fsh} given as reroute reason
|
||||
CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisionship reason
|
||||
FirmSupervisionRInfo: Shown are supervisionships where either supervisor or supervisee no longer belong to the company associated with the supervisionship.
|
||||
SupervisionViolationChoice: Company association missing for
|
||||
SupervisionViolationEither: anyone
|
||||
SupervisionViolationSupervisor: Supervisor
|
||||
SupervisionViolationClient: Supervisee
|
||||
SupervisionViolationBoth: both
|
||||
SupervisionsRemoved n m: #{n}/#{m} #{pluralENs n "Supervisionship"} removed.
|
||||
SupervisionsEdited n m: #{n}/#{m} #{pluralENs n "Supervisionship"} edited.
|
||||
ASChangeCompany: Change supervisionship annotations
|
||||
ASRemoveAssociation: Delete supervisionship
|
||||
FirmNameNotFound: No company found with this name/shorthand or AVS number.
|
||||
FirmNameAmbiguous: Company name/shorthand or AVS number is amiguous.
|
||||
@ -1,20 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
-- Description of companies associated with users
|
||||
|
||||
Company
|
||||
name CompanyName -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment
|
||||
shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
|
||||
avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies
|
||||
prefersPostal Bool default=true -- new company users prefers letters by post instead of email
|
||||
postAddress StoredMarkup Maybe -- default company postal address, including company name
|
||||
email UserEmail Maybe -- Case-insensitive generic company eMail address
|
||||
pinPassword Bool default=true -- new company users only: should sensitive PDF email attachement be protected by a password?
|
||||
-- UniqueCompanyName name -- Should be Unique in AVS, but we do not yet need to enforce it
|
||||
-- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already
|
||||
UniqueCompanyAvsId avsId -- Should be the key, is not for historical reasons and for convenience in URLs and columns
|
||||
Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
|
||||
deriving Ord Eq Show Generic Binary
|
||||
|
||||
@ -1,53 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.systems>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Foundation.Yesod.StaticContent
|
||||
( addStaticContent
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (addStaticContent)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
import Data.Bits (Bits(zeroBits))
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
addStaticContent :: Text
|
||||
-> Text
|
||||
-> Lazy.ByteString
|
||||
-> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
|
||||
addStaticContent ext _mime content = do
|
||||
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
|
||||
let expiry = maybe 0 ceiling memcachedExpiry
|
||||
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
||||
addItem = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
||||
catchIf Memcached.isKeyNotFound touch . const $
|
||||
handleIf Memcached.isKeyExists (const $ return ()) addItem
|
||||
return . Left $ pack absoluteLink
|
||||
where
|
||||
-- Generate a unique filename based on the content itself, this is used
|
||||
-- for deduplication so a collision resistant hash function is required
|
||||
--
|
||||
-- SHA-3 (SHAKE256) seemed to be a future-proof choice
|
||||
--
|
||||
-- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
|
||||
-- padding after base64-conversion~~ for backwards compatibility
|
||||
fileName = (<.> unpack ext)
|
||||
. unpack
|
||||
. decodeUtf8
|
||||
. Base64.encodeUnpadded
|
||||
. (convert :: Digest (SHAKE256 144) -> ByteString)
|
||||
. runConduitPure
|
||||
$ C.sourceLazy content .| sinkHash
|
||||
@ -1,438 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Handler.Admin
|
||||
( module Handler.Admin
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
-- import Data.Either
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
-- import qualified Data.Text.Lazy.Encoding as LBS
|
||||
|
||||
-- import qualified Control.Monad.Catch as Catch
|
||||
-- import Servant.Client (ClientError(..), ResponseF(..))
|
||||
-- import Text.Blaze.Html (preEscapedToHtml)
|
||||
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Jobs
|
||||
import Utils.Company (areThereInsaneCompanySupervisions)
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Users
|
||||
-- import Handler.Utils.Company
|
||||
import Handler.Health.Interface
|
||||
import Handler.Users (AllUsersAction(..))
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
import Handler.Admin.Tokens as Handler.Admin
|
||||
import Handler.Admin.Crontab as Handler.Admin
|
||||
import Handler.Admin.Avs as Handler.Admin
|
||||
import Handler.Admin.Ldap as Handler.Admin
|
||||
|
||||
|
||||
-- Types and Template Haskell
|
||||
data ProblemTableAction = ProblemTableMarkSolved
|
||||
| ProblemTableMarkUnsolved
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''ProblemTableAction id
|
||||
|
||||
data ProblemTableActionData = ProblemTableMarkSolvedData
|
||||
| ProblemTableMarkUnsolvedData -- Placeholder, remove later
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
-- Handlers
|
||||
getAdminR :: Handler Html
|
||||
getAdminR = redirect AdminProblemsR
|
||||
|
||||
getAdminProblemsR, postAdminProblemsR :: Handler Html
|
||||
getAdminProblemsR = handleAdminProblems Nothing
|
||||
|
||||
handleAdminProblems :: Maybe Widget -> Handler Html
|
||||
handleAdminProblems mbProblemTable = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
cutOffOldDays = 1
|
||||
cutOffOldTime = toMidnight $ addDays (-cutOffOldDays) nowaday
|
||||
|
||||
-- we abuse messageTooltip for colored icons here
|
||||
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
msgErrorTooltip <- messageI Error MsgMessageError
|
||||
|
||||
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
|
||||
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
|
||||
flagNonZero :: Int -> Widget
|
||||
flagNonZero n | n <= 0 = flagError True
|
||||
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
|
||||
|
||||
showDiffTime t =
|
||||
let d = diffUTCTime now t
|
||||
in guardMonoid (d > secondsToNominalDiffTime 30) [whamlet|<small>_{MsgProblemLastCheckTime (formatDiffDays d)}|]
|
||||
|
||||
(usersAreReachable, aurTime) <- areAllUsersReachable -- cached
|
||||
(not -> thereAreInsaneFirmSupervisions, ifsTime) <- areThereInsaneCompanySupervisions -- cached
|
||||
(driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,)
|
||||
<$> allDriversHaveAvsId now
|
||||
<*> allRDriversHaveFs now
|
||||
<*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]
|
||||
<*> exists [PrintAcknowledgeProcessed ==. False]
|
||||
(interfaceOks, interfaceTable) <- runDB $ mkInterfaceLogTable mempty
|
||||
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
||||
-- interfacesOk = all snd interfaceOks
|
||||
|
||||
diffLics <- try retrieveDifferingLicences >>= \case
|
||||
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
|
||||
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
|
||||
(Right (AvsLicenceDifferences{..},_)) -> do
|
||||
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
|
||||
void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
|
||||
return $ Right
|
||||
( Set.size avsLicenceDiffRevokeAll
|
||||
, Set.size avsLicenceDiffGrantVorfeld
|
||||
, Set.size avsLicenceDiffRevokeRollfeld
|
||||
, Set.size avsLicenceDiffGrantRollfeld
|
||||
)
|
||||
-- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
|
||||
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
|
||||
-- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches`
|
||||
-- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
|
||||
-- -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
|
||||
-- ex -> return $ Left $ text2widget $ tshow ex)
|
||||
-- , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
|
||||
-- ]
|
||||
|
||||
rerouteMail <- getsYesod $ view _appMailRerouteTo
|
||||
problemLogTable <- maybeM (snd <$> runDB mkProblemLogTable) return $ return mbProblemTable -- formResult only processed in POST-Handler
|
||||
|
||||
siteLayoutMsg MsgProblemsHeading $ do
|
||||
setTitleI MsgProblemsHeading
|
||||
$(widgetFile "admin-problems")
|
||||
|
||||
postAdminProblemsR = do
|
||||
(problemLogRes, problemLogTable) <- runDB mkProblemLogTable
|
||||
formResult problemLogRes procProblems
|
||||
handleAdminProblems $ Just problemLogTable
|
||||
where
|
||||
procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
|
||||
procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids
|
||||
procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
|
||||
|
||||
actUpdate markdone pids = do
|
||||
mauid <- maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
let (pls_fltr,newv,msg) | markdone = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved)
|
||||
| otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened)
|
||||
(fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids]
|
||||
[ProblemLogSolved =. newv, ProblemLogSolver =. mauid]
|
||||
let no_req = Set.size pids
|
||||
mkind = if oks < no_req || no_req <= 0 then Warning else Success
|
||||
addMessageI mkind $ msg oks
|
||||
when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
|
||||
|
||||
getProblemUnreachableR, postProblemUnreachableR :: Handler Html
|
||||
getProblemUnreachableR = postProblemUnreachableR
|
||||
postProblemUnreachableR = do
|
||||
unreachables <- runDBRead retrieveUnreachableUsers
|
||||
|
||||
-- the following form is a nearly identicaly copy from Handler.Users:
|
||||
((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
|
||||
let noreachUsersWgt = wrapForm noreachUsersWgt' def
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute ProblemUnreachableR
|
||||
, formEncoding = noreachUsersEnctype
|
||||
}
|
||||
formResult noreachUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables
|
||||
redirect ProblemUnreachableR
|
||||
AllUsersAvsSync -> do
|
||||
n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing
|
||||
addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
|
||||
redirect ProblemUnreachableR
|
||||
|
||||
siteLayoutMsg MsgProblemsUnreachableHeading $ do
|
||||
setTitleI MsgProblemsUnreachableHeading
|
||||
[whamlet|
|
||||
<section>
|
||||
<h3>_{MsgProblemsUnreachableButtons}
|
||||
^{noreachUsersWgt}
|
||||
<section>
|
||||
#{length unreachables} _{MsgProblemsUnreachableBody}
|
||||
<ul>
|
||||
$forall usr <- unreachables
|
||||
<li>
|
||||
^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|
||||
|]
|
||||
|
||||
getProblemFbutNoR :: Handler Html
|
||||
getProblemFbutNoR = do
|
||||
now <- liftIO getCurrentTime
|
||||
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
|
||||
siteLayoutMsg MsgProblemsRWithoutFHeading $ do
|
||||
setTitleI MsgProblemsRWithoutFHeading
|
||||
[whamlet|
|
||||
<section>
|
||||
_{MsgProblemsRWithoutFBody}
|
||||
<ul>
|
||||
$forall usr <- rnofs
|
||||
<li>
|
||||
^{linkUserWidget AdminUserR usr}
|
||||
|]
|
||||
|
||||
getProblemWithoutAvsId :: Handler Html
|
||||
getProblemWithoutAvsId = do
|
||||
now <- liftIO getCurrentTime
|
||||
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
|
||||
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
|
||||
setTitleI MsgProblemsNoAvsIdHeading
|
||||
[whamlet|
|
||||
<section>
|
||||
_{MsgProblemsNoAvsIdBody}
|
||||
<ul>
|
||||
$forall usr <- rnofs
|
||||
<li>
|
||||
^{linkUserWidget AdminUserR usr}
|
||||
|]
|
||||
|
||||
{-
|
||||
mkUnreachableUsersTable = do
|
||||
let dbtSQLQuery user -> do
|
||||
E.where_ $ E.isNothing (user E.^. UserPostAddress)
|
||||
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
|
||||
pure user
|
||||
dbtRowKey = (E.^. UserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade =
|
||||
-}
|
||||
|
||||
areAllUsersReachable :: Handler (Bool, UTCTime)
|
||||
areAllUsersReachable = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-users-reachable|] $ do
|
||||
now <- liftIO getCurrentTime
|
||||
res <- runDBRead retrieveUnreachableUsers
|
||||
-- res <- E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
|
||||
$logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
|
||||
return (null res,now)
|
||||
|
||||
-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
-- retrieveUnreachableUsers' = do
|
||||
-- user <- E.from $ E.table @User
|
||||
-- E.where_ $ E.isNothing (user E.^. UserPostAddress)
|
||||
-- E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
|
||||
-- E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
|
||||
-- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
|
||||
-- return user
|
||||
|
||||
retrieveUnreachableUsers :: DBReadUq' [Entity User]
|
||||
retrieveUnreachableUsers = do
|
||||
emailOnlyUsers <- E.select $ do
|
||||
user <- E.from $ E.table @User
|
||||
E.where_ $ E.isNothing (user E.^. UserPostAddress)
|
||||
E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
|
||||
E.&&. E.notExists (do
|
||||
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany
|
||||
`E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
||||
E.where_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
||||
E.&&. usrCmp E.^. UserCompanyUseCompanyAddress
|
||||
E.&&. E.isJust (cmp E.^. CompanyPostAddress)
|
||||
)
|
||||
return user
|
||||
filterM hasInvalidEmail emailOnlyUsers
|
||||
-- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
|
||||
where
|
||||
hasInvalidEmail = fmap isNothing . getUserEmail
|
||||
|
||||
|
||||
allDriversHaveAvsId :: UTCTime -> DBReadUq Bool
|
||||
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
|
||||
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
|
||||
|
||||
{-
|
||||
-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
|
||||
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
retrieveDriversWithoutAvsId' nowaday = do
|
||||
(usr :& qualUsr :& qual) <- E.from $ E.table @User
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
|
||||
`E.innerJoin` E.table @Qualification
|
||||
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
|
||||
E.where_ $ -- is avs licence
|
||||
E.isJust (qual E.^. QualificationAvsLicence)
|
||||
E.&&. (qualUsr & validQualification nowaday)
|
||||
E.&&. -- AvsId is unknown
|
||||
E.notExists (do
|
||||
avsUsr <- E.from $ E.table @UserAvs
|
||||
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
|
||||
)
|
||||
return usr
|
||||
-}
|
||||
|
||||
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
|
||||
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
retrieveDriversWithoutAvsId now = do
|
||||
usr <- E.from $ E.table @User
|
||||
E.where_ $
|
||||
E.exists (do -- a valid avs licence
|
||||
(qual :& qualUsr) <- E.from (E.table @Qualification
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
|
||||
E.where_ $ -- is avs licence
|
||||
E.isJust (qual E.^. QualificationAvsLicence)
|
||||
E.&&. (qualUsr & validQualification now) -- currently valid
|
||||
E.&&. -- matches user
|
||||
(qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
|
||||
)
|
||||
E.&&.
|
||||
E.notExists (do -- a known AvsId
|
||||
avsUsr <- E.from $ E.table @UserAvs
|
||||
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
|
||||
)
|
||||
return usr
|
||||
|
||||
|
||||
allRDriversHaveFs :: UTCTime -> DBReadUq Bool
|
||||
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
|
||||
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
|
||||
|
||||
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
|
||||
retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
retrieveDriversRWithoutF now = do
|
||||
usr <- E.from $ E.table @User
|
||||
let hasValidQual lic = do
|
||||
(qual :& qualUsr) <- E.from (E.table @Qualification
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
|
||||
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
|
||||
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
|
||||
E.&&. (qualUsr & validQualification now) -- currently valid
|
||||
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
|
||||
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
|
||||
return usr
|
||||
|
||||
|
||||
|
||||
type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog)
|
||||
queryProblem = $(E.sqlLOJproj 3 1)
|
||||
|
||||
querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
querySolver = $(E.sqlLOJproj 3 2)
|
||||
|
||||
queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryUser = $(E.sqlLOJproj 3 3)
|
||||
|
||||
type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User))
|
||||
resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog)
|
||||
resultProblem = _dbrOutput . _1
|
||||
|
||||
resultSolver :: Traversal' ProblemLogTableData (Entity User)
|
||||
resultSolver = _dbrOutput . _2 . _Just
|
||||
|
||||
resultUser :: Traversal' ProblemLogTableData (Entity User)
|
||||
resultUser = _dbrOutput . _3 . _Just
|
||||
|
||||
mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
|
||||
mkProblemLogTable = do
|
||||
-- problem_types <- E.select $ do
|
||||
-- ap <- E.from $ E.table @ProblemLog
|
||||
-- let res = ap E.^. ProblemLogInfo E.->>. "problem"
|
||||
-- E.groupBy res
|
||||
-- return res
|
||||
over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
where
|
||||
-- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
|
||||
dbtIdent = "problem-log" :: Text
|
||||
dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
|
||||
-- EL.on (usr E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo E.->>. "user")) -- works
|
||||
EL.on (usr E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user")
|
||||
EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
|
||||
return (problem, solver, usr)
|
||||
dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
|
||||
, sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t
|
||||
, sortable (Just "info") (i18nCell MsgAdminProblemInfo) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
|
||||
-- , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
|
||||
, sortable (Just "firm") (i18nCell MsgTableCompany) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany)
|
||||
, sortable (Just "user") (i18nCell MsgAdminProblemUser) $ \(preview resultUser -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
|
||||
, sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
|
||||
, ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
|
||||
-- , ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
|
||||
, ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
|
||||
, ("user" , sortUserNameBareM queryUser)
|
||||
, ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
|
||||
, ("solver", sortUserNameBareM querySolver)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName))
|
||||
, ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
|
||||
, ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
|
||||
, ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
|
||||
-- , ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
|
||||
, ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
|
||||
ifNothingM criterion True $ \(crit::Text) -> do
|
||||
let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
|
||||
protxt <- adminProblem2Text problem
|
||||
return $ crit `Text.isInfixOf` protxt
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemUser & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "solver" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
|
||||
, prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo)
|
||||
, prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableCompanyShort)
|
||||
, prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
|
||||
]
|
||||
acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
|
||||
acts = Map.fromList
|
||||
[ (ProblemTableMarkSolved , pure ProblemTableMarkSolvedData)
|
||||
, (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional
|
||||
= renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> multiActionA acts (fslI MsgTableAction) (Just ProblemTableMarkSolved)
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
validator = def & defaultSorting [SortAscBy "time"]
|
||||
& defaultFilter (singletonMap "solved" [toPathPiece False])
|
||||
postprocess :: FormResult (First ProblemTableActionData, DBFormResult ProblemLogId Bool ProblemLogTableData)
|
||||
-> FormResult ( ProblemTableActionData, Set ProblemLogId)
|
||||
postprocess inp = do
|
||||
(First (Just act), usrMap) <- inp
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
return (act, usrSet)
|
||||
|
||||
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
|
||||
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,150 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.CommCenter
|
||||
( getCommCenterR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
-- import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Text as Text
|
||||
import Data.Text.Lens (packed)
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
|
||||
data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe CCTableAction
|
||||
instance Finite CCTableAction
|
||||
nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''CCTableAction id
|
||||
|
||||
data CCTableActionData = CCActDummyData
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
|
||||
type CCTableExpr =
|
||||
( (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
|
||||
`E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
|
||||
)
|
||||
|
||||
queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
|
||||
|
||||
queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
|
||||
queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
|
||||
|
||||
queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
|
||||
|
||||
queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
|
||||
queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
|
||||
|
||||
type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
|
||||
|
||||
resultRecipientMail :: Traversal' CCTableData (Entity User)
|
||||
resultRecipientMail = _dbrOutput . _1 . _Just
|
||||
|
||||
resultMail :: Traversal' CCTableData (Entity SentMail)
|
||||
resultMail = _dbrOutput . _2 . _Just
|
||||
|
||||
resultRecipientPrint :: Traversal' CCTableData (Entity User)
|
||||
resultRecipientPrint = _dbrOutput . _3 . _Just
|
||||
|
||||
resultPrint :: Traversal' CCTableData (Entity PrintJob)
|
||||
resultPrint = _dbrOutput . _4 . _Just
|
||||
|
||||
|
||||
mkCCTable :: DB (Any, Widget)
|
||||
mkCCTable = do
|
||||
let
|
||||
dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
|
||||
dbtSQLQuery ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
|
||||
EL.on $ recipientMail E.?. UserId E.==. E.joinV (mail E.?. SentMailRecipient)
|
||||
EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
|
||||
-- EL.on $ recipientMail E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
|
||||
EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
|
||||
-- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed for full outer join
|
||||
-- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
|
||||
return (recipientMail, mail, recipientPrint, printJob)
|
||||
-- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
|
||||
dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
|
||||
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
|
||||
[ sortable (Just "date") (i18nCell MsgPrintJobCreated) $ \row ->
|
||||
let tprint = row ^? resultPrint . _entityVal . _printJobCreated
|
||||
tmail = row ^? resultMail . _entityVal . _sentMailSentAt
|
||||
in maybeCell (tprint <|> tmail) dateTimeCell
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \row ->
|
||||
let uprint = row ^? resultRecipientPrint
|
||||
umail = row ^? resultRecipientMail
|
||||
in maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
|
||||
, sortable Nothing (i18nCell MsgCommBody) $ \row -> if
|
||||
| (Just k) <- row ^? resultPrint . _entityKey
|
||||
-> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
|
||||
| (Just k) <- row ^? resultMail . _entityKey
|
||||
-> anchorCellM (MailHtmlR <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
|
||||
| otherwise
|
||||
-> mempty
|
||||
, sortable Nothing (i18nCell MsgCommSubject) $ \row ->
|
||||
let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
|
||||
msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
|
||||
in maybeCell (tsubject <|> msubject) textCell
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "date" $ SortColumn $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
|
||||
, singletonMap "recipient" $ SortColumns $ \row ->
|
||||
[ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname , queryRecipientMail row E.?. UserSurname ]
|
||||
, SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
|
||||
]
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ ("sentTo" , FilterColumn . E.mkDayFilterTo
|
||||
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
|
||||
, ("sentFrom" , FilterColumn . E.mkDayFilterFrom
|
||||
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
|
||||
, ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
||||
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
|
||||
, ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
||||
$ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
|
||||
,E.str2text' $ queryMail row E.?. SentMailHeaders ])
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "sentTo" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentBefore)
|
||||
, prismAForm (singletonFilter "sentFrom" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentAfter)
|
||||
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "comms"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = def
|
||||
psValidator = def & defaultSorting [SortDescBy "date"]
|
||||
dbTable psValidator DBTable{..}
|
||||
|
||||
getCommCenterR :: Handler Html
|
||||
getCommCenterR = do
|
||||
(_, ccTable) <- runDB mkCCTable
|
||||
siteLayoutMsg MsgMenuCommCenter $ do
|
||||
setTitleI MsgMenuCommCenter
|
||||
$(widgetFile "comm-center")
|
||||
|
||||
@ -1,234 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2023-2025 Steffen Jost <S.Jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Firm.Supervision
|
||||
( getFirmsSupervisionR , postFirmsSupervisionR
|
||||
)
|
||||
where
|
||||
|
||||
import Import
|
||||
|
||||
-- import Jobs
|
||||
import Utils.Company
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Company
|
||||
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Csv as Csv
|
||||
-- import qualified Data.Text as T
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Conduit.List as C
|
||||
-- import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
import Database.Persist.Postgresql
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import Database.Esqueleto.Utils.TH
|
||||
|
||||
|
||||
-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
|
||||
-- decryptUser = decrypt
|
||||
|
||||
-- encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
|
||||
-- encryptUser = encrypt
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Supervision Sanity
|
||||
|
||||
data ActSupervision = ASChangeCompany | ASRemoveAssociation
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''ActSupervision $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''ActSupervision id
|
||||
|
||||
data ActSupervisionData
|
||||
= ASChangeCompanyData { asTblCompany :: Maybe CompanyShorthand, asTblReason :: Maybe Text }
|
||||
| ASRemoveAssociationData
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
data SupervisionViolation = SupervisionViolationEither | SupervisionViolationClient | SupervisionViolationSupervisor | SupervisionViolationBoth
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''SupervisionViolation $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''SupervisionViolation id
|
||||
|
||||
supervisionViolationField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m SupervisionViolation
|
||||
-- supervisionViolationField = radioGroupField (Just $ SomeMessage MsgSupervisionViolationEither) $ optionsFinite
|
||||
supervisionViolationField = radioGroupField Nothing $ optionsFinite
|
||||
|
||||
type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User)
|
||||
|
||||
mkSupervisionTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget)
|
||||
mkSupervisionTable = over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
where
|
||||
dbtIdent = "sanity-super" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
|
||||
queryRelation :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserSupervisor)
|
||||
queryRelation = $(E.sqlIJproj 3 1)
|
||||
querySupervisor :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
|
||||
querySupervisor = $(E.sqlIJproj 3 2)
|
||||
queryClient :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
|
||||
queryClient = $(E.sqlIJproj 3 3)
|
||||
|
||||
resultRelation :: Lens' TblSupervisionData (Entity UserSupervisor)
|
||||
resultRelation = _dbrOutput . _1
|
||||
resultSupervisor :: Lens' TblSupervisionData (Entity User)
|
||||
resultSupervisor = _dbrOutput . _2
|
||||
resultClient :: Lens' TblSupervisionData (Entity User)
|
||||
resultClient = _dbrOutput . _3
|
||||
|
||||
dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do
|
||||
EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
|
||||
EL.on $ uus E.^. UserSupervisorUser E.==. sub E.^. UserId
|
||||
E.where_ $ E.isJust (uus E.^. UserSupervisorCompany)
|
||||
return (uus, spr, sub)
|
||||
dbtRowKey = queryRelation >>> (E.^. UserSupervisorId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ dbSelect (applying _2) id (return . view (resultRelation . _entityKey))
|
||||
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
|
||||
, sortable (Just "reason") (i18nCell MsgUserSupervisorReason) $ \(view $ resultRelation . _entityVal . _userSupervisorReason -> r) -> maybeCell r textCell
|
||||
, sortable (Just "rel-comp") (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\
|
||||
, sortable (Just "supervisor") (i18nCell MsgTableSupervisor) $ \(view $ resultSupervisor -> u) -> cellHasUserModal ForProfileDataR u
|
||||
, sortable (Just "super-comp") (i18nCell MsgTableCompanies) $ \(view $ resultSupervisor . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||
maybeMonoid <$> wgtCompanies True uid
|
||||
, sortable (Just "client") (i18nCell MsgTableSupervisee) $ \(view $ resultClient -> u) -> cellHasUserModal ForProfileDataR u
|
||||
, sortable (Just "client-comp") (i18nCell MsgTableCompanies) $ \(view $ resultClient . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||
maybeMonoid <$> wgtCompanies True uid
|
||||
]
|
||||
validator = def & defaultSorting [SortAscBy "rel-comp", SortAscBy "supervisor", SortAscBy "client"]
|
||||
& defaultFilter (singletonMap "violation" [toPathPiece SupervisionViolationEither])
|
||||
dbtSorting = Map.fromList
|
||||
[ ("reason" , SortColumn $ queryRelation >>> (E.^. UserSupervisorReason))
|
||||
, ("rel-comp" , SortColumn $ queryRelation >>> (E.^. UserSupervisorCompany))
|
||||
, ("reroute" , SortColumn $ queryRelation >>> (E.^. UserSupervisorRerouteNotifications))
|
||||
, ("supervisor" , SortColumn $ querySupervisor >>> (E.^. UserDisplayName))
|
||||
, ("client" , SortColumn $ queryClient >>> (E.^. UserDisplayName))
|
||||
, ("super-comp" , SortColumn (\row -> E.subSelect $ do
|
||||
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySupervisor row E.^. UserId
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
||||
return (cmp E.^. CompanyName)
|
||||
))
|
||||
, ("client-comp" , SortColumn (\row -> E.subSelect $ do
|
||||
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. queryClient row E.^. UserId
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
||||
return (cmp E.^. CompanyName)
|
||||
))
|
||||
]
|
||||
|
||||
dbtFilter = Map.fromList
|
||||
[ ("violation", FilterColumn $ \(queryRelation -> us) (getLast -> criterion) -> case criterion of
|
||||
Just SupervisionViolationSupervisor -> missingCompanySupervisor us
|
||||
Just SupervisionViolationClient -> missingCompanyClient us
|
||||
Just SupervisionViolationBoth -> missingCompanySupervisor us E.&&. missingCompanyClient us
|
||||
_ -> missingCompanySupervisor us E.||. missingCompanyClient us
|
||||
)
|
||||
, ("rel-company", FilterColumn $ E.mkExistsFilter $ \(queryRelation -> us) (commaSeparatedText -> criteria) -> do
|
||||
let numCrits = setMapMaybe readMay criteria
|
||||
cmp <- E.from $ E.table @Company
|
||||
E.where_ $ cmp E.^. CompanyId E.=?. us E.^. UserSupervisorCompany
|
||||
E.&&. E.or (
|
||||
bcons (notNull numCrits)
|
||||
(E.mkExactFilter (E.^. CompanyAvsId) cmp numCrits)
|
||||
[E.mkContainsFilterWith CI.mk (E.^. CompanyName) cmp criteria
|
||||
,E.mkContainsFilterWith CI.mk (E.^. CompanyShorthand) cmp criteria
|
||||
]
|
||||
)
|
||||
)
|
||||
, ("supervisor-company", fltrCompanyShortNrUsr (querySupervisor >>> (E.^. UserId)))
|
||||
, ("client-company" , fltrCompanyShortNrUsr (queryClient >>> (E.^. UserId)))
|
||||
, ("supervisor", FilterColumn . E.mkContainsFilter $ querySupervisor >>> (E.^. UserDisplayName))
|
||||
, ("client" , FilterColumn . E.mkContainsFilter $ queryClient >>> (E.^. UserDisplayName))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat -- Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
|
||||
[ prismAForm (singletonFilter "violation" . maybePrism _PathPiece) mPrev $ aopt supervisionViolationField (fslI MsgSupervisionViolationChoice)
|
||||
, prismAForm (singletonFilter "rel-company") mPrev $ aopt textField (fslI MsgUserSupervisorCompany & setTooltip MsgTableFilterCommaNameNr)
|
||||
, prismAForm (singletonFilter "supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
||||
, fltrCompanyNameNrUsrHdrUI "supervisor-company" (someMessages [MsgTableSupervisor, MsgTableCompanyShort]) mPrev
|
||||
, prismAForm (singletonFilter "client") mPrev $ aopt textField (fslI MsgTableSupervisee)
|
||||
, fltrCompanyNameNrUsrHdrUI "client-company" (someMessages [MsgTableSupervisee, MsgTableCompanyShort]) mPrev
|
||||
]
|
||||
|
||||
suggestionSupervision :: Handler (OptionList Text)
|
||||
suggestionSupervision = mkOptionListText <$> runDB
|
||||
(E.select $ do
|
||||
us <- E.from $ E.table @UserSupervisor
|
||||
let reason = us E.^. UserSupervisorReason
|
||||
countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||
E.where_ $ E.isJust reason
|
||||
E.groupBy reason
|
||||
E.orderBy [E.desc countRows']
|
||||
E.limit 9
|
||||
pure $ E.coalesceDefault [reason] (E.val "")
|
||||
)
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional =
|
||||
let acts :: Map ActSupervision (AForm Handler ActSupervisionData)
|
||||
acts = mconcat
|
||||
[ singletonMap ASChangeCompany $ ASChangeCompanyData
|
||||
<$> aopt companyField (fslI MsgUserSupervisorCompany) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist suggestionSupervision) (fslI MsgUserSupervisorReason & setTooltip MsgStarKeepsEmptyDeletes) (Just $ Just "*")
|
||||
, singletonMap ASRemoveAssociation $ pure ASRemoveAssociationData
|
||||
]
|
||||
in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
|
||||
postprocess :: FormResult (First ActSupervisionData, DBFormResult UserSupervisorId Bool TblSupervisionData)
|
||||
-> FormResult ( ActSupervisionData, Set UserSupervisorId)
|
||||
postprocess inp = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
return (act, jobSet)
|
||||
|
||||
|
||||
getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html
|
||||
getFirmsSupervisionR = postFirmsSupervisionR
|
||||
postFirmsSupervisionR = do
|
||||
(svRes, svTbl) <- runDB mkSupervisionTable
|
||||
formResult svRes $ \case
|
||||
(ASRemoveAssociationData, relations) -> do
|
||||
nrDel <- runDB $ deleteWhereCount [UserSupervisorId <-. Set.toList relations]
|
||||
addMessageOutOfI MsgSupervisionsRemoved nrDel $ Set.size relations
|
||||
reloadKeepGetParams FirmsSupervisionR
|
||||
(ASChangeCompanyData{..}, relations) -> do
|
||||
let rsnChg = case asTblReason of
|
||||
Just "*" -> Nothing
|
||||
_ -> Just $ UserSupervisorReason =. asTblReason
|
||||
chgs = mcons rsnChg [UserSupervisorCompany =. CompanyKey <$> canonical asTblCompany]
|
||||
nrChg <- runDB $ updateWhereCount [UserSupervisorId <-. Set.toList relations] chgs
|
||||
addMessageOutOfI MsgSupervisionsEdited nrChg $ Set.size relations
|
||||
reloadKeepGetParams FirmsSupervisionR
|
||||
-- TODO: Bug Firmenwechsel: Bestehende Ansprechpartnerbeziehung - Firma ändern!
|
||||
let heading = MsgMenuFirmsSupervision
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
[whamlet|$newline never
|
||||
<p>
|
||||
_{MsgFirmSupervisionRInfo} In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene #
|
||||
nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist:
|
||||
<p>
|
||||
^{svTbl}
|
||||
|]
|
||||
@ -1,339 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2023-2025 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||
|
||||
module Handler.LMS.Learners
|
||||
( getLmsLearnersR
|
||||
, getLmsLearnersDirectR
|
||||
, getLmsOrphansR
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Csv
|
||||
import Handler.Utils.LMS
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Csv as Csv
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Conduit.List as C
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
|
||||
{ csvLUTident :: LmsIdent
|
||||
, csvLUTpin :: Text
|
||||
, csvLUTresetPin, csvLUTdelete, csvLUTstaff -- V1
|
||||
, csvLUTresetTries, csvLUTlock :: LmsBool -- V2
|
||||
}
|
||||
deriving Generic
|
||||
makeLenses_ ''LmsUserTableCsv
|
||||
|
||||
lmsUserDelete2csv :: LmsIdent -> LmsUserTableCsv
|
||||
lmsUserDelete2csv lid = LmsUserTableCsv
|
||||
{ csvLUTident = lid
|
||||
, csvLUTpin = "00000000"
|
||||
, csvLUTresetPin = LmsBool False
|
||||
, csvLUTdelete = LmsBool $ isJust $ Text.find Char.isLetter $ getLmsIdent lid -- safety-catch: do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter
|
||||
, csvLUTstaff = LmsBool False
|
||||
, csvLUTresetTries= LmsBool False
|
||||
, csvLUTlock = LmsBool True
|
||||
}
|
||||
|
||||
-- | Mundane conversion needed for direct download without dbTable only
|
||||
lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
|
||||
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
|
||||
{ csvLUTident = lmsUserIdent
|
||||
, csvLUTpin = lmsUserPin
|
||||
, csvLUTresetPin = LmsBool lmsUserResetPin
|
||||
, csvLUTdelete = LmsBool (lmsUserToDelete cutoff lu)
|
||||
, csvLUTstaff = LmsBool (lmsUserStaff lu)
|
||||
, csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended!
|
||||
, csvLUTlock = LmsBool (lmsUserToLock lu)
|
||||
}
|
||||
|
||||
-- csv without headers
|
||||
instance Csv.ToRecord LmsUserTableCsv
|
||||
instance Csv.FromRecord LmsUserTableCsv
|
||||
|
||||
-- csv with headers
|
||||
lmsUserTableCsvHeader :: Csv.Header
|
||||
lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff, csvLmsResetTries, csvLmsLock ]
|
||||
|
||||
instance ToNamedRecord LmsUserTableCsv where
|
||||
toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
|
||||
[ csvLmsIdent Csv..= csvLUTident
|
||||
, csvLmsPin Csv..= csvLUTpin
|
||||
, csvLmsResetPin Csv..= csvLUTresetPin
|
||||
, csvLmsDelete Csv..= csvLUTdelete
|
||||
, csvLmsStaff Csv..= csvLUTstaff
|
||||
, csvLmsResetTries Csv..= csvLUTresetTries
|
||||
, csvLmsLock Csv..= csvLUTlock
|
||||
]
|
||||
instance FromNamedRecord LmsUserTableCsv where
|
||||
parseNamedRecord (lsfHeaderTranslate -> csv)
|
||||
= LmsUserTableCsv
|
||||
<$> csv Csv..: csvLmsIdent
|
||||
<*> csv Csv..: csvLmsPin
|
||||
<*> csv Csv..: csvLmsResetPin
|
||||
<*> csv Csv..: csvLmsDelete
|
||||
<*> csv Csv..: csvLmsStaff
|
||||
<*> csv Csv..: csvLmsResetTries
|
||||
<*> csv Csv..: csvLmsLock
|
||||
|
||||
instance CsvColumnsExplained LmsUserTableCsv where
|
||||
csvColumnsExplanations _ = Map.fromList
|
||||
[ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
|
||||
, (csvLmsPin , msg2widget MsgCsvColumnLmsPin)
|
||||
, (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
|
||||
, (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete)
|
||||
, (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff)
|
||||
, (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries)
|
||||
, (csvLmsLock , msg2widget MsgCsvColumnLmsLock)
|
||||
]
|
||||
|
||||
|
||||
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
|
||||
mkUserTable _sid qsh qid cutoff = do
|
||||
dbtCsvName <- csvFilenameLmsUser qsh
|
||||
let dbtCsvSheetName = dbtCsvName
|
||||
let
|
||||
userDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery lmsuser = do
|
||||
E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
|
||||
return lmsuser
|
||||
dbtRowKey = (E.^. LmsUserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
|
||||
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
|
||||
) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin
|
||||
, sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset
|
||||
, sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser
|
||||
, sortable Nothing (i18nCell MsgTableLmsStaff) $ \(view $ _dbrOutput . _entityVal . _lmsUserStaff -> staff) -> ifIconCell staff IconOK
|
||||
, sortable (Just csvLmsResetTries)(i18nCell MsgTableLmsResetTries) $ \(view $ _dbrOutput . _entityVal . _lmsUserToResetTries -> reset) -> ifIconCell reset IconResetTries
|
||||
, sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsUserToLock -> lock ) -> ifIconCell lock IconLocked
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ (csvLmsIdent , SortColumn (E.^. LmsUserIdent))
|
||||
, (csvLmsPin , SortColumn (E.^. LmsUserPin))
|
||||
, (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin))
|
||||
, (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff))
|
||||
-- , (csvLmsStaff , E.false) -- currently always false
|
||||
, (csvLmsResetTries , SortColumn lmsUserToResetTriesExpr)
|
||||
, (csvLmsLock , SortColumn lmsUserToLockExpr)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsUserIdent ))
|
||||
, (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift boolField') (fslI MsgTableLmsResetPin)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms-user"
|
||||
dbtCsvEncode = Just DBTCsvEncode {..}
|
||||
where
|
||||
dbtCsvExportForm = pure ()
|
||||
dbtCsvNoExportData = Just id
|
||||
dbtCsvExampleData = Nothing
|
||||
dbtCsvHeader = const $ return lmsUserTableCsvHeader
|
||||
dbtCsvDoEncode () = C.map (doEncode' . view _2)
|
||||
doEncode' = LmsUserTableCsv
|
||||
<$> view (_dbrOutput . _entityVal . _lmsUserIdent)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserPin)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . to lmsUserStaff . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . to lmsUserToResetTries . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . to lmsUserToLock . _lmsBool)
|
||||
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
|
||||
userDBTableValidator = def
|
||||
& defaultSorting [SortAscBy csvLmsIdent]
|
||||
dbTable userDBTableValidator userDBTable
|
||||
|
||||
getQidCutoff :: SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime)
|
||||
getQidCutoff sid qsh = do
|
||||
Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
now <- liftIO getCurrentTime
|
||||
let cutoff = lmsDeletionDate now auditDur
|
||||
return (qid, cutoff)
|
||||
|
||||
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsLearnersR sid qsh = do
|
||||
(lmsTable, nr_orphans) <- runDB $ do
|
||||
(qid, cutoff) <- getQidCutoff sid qsh
|
||||
lmsTable <- view _2 <$> mkUserTable sid qsh qid cutoff
|
||||
nr_orphans <- count [LmsOrphanQualification ==. qid]
|
||||
return (lmsTable, nr_orphans)
|
||||
when (nr_orphans > 0) $ addMessageI Warning $ MsgLmsOrphanNr nr_orphans
|
||||
siteLayoutMsg MsgMenuLmsLearners $ do
|
||||
setTitleI MsgMenuLmsLearners
|
||||
lmsTable
|
||||
|
||||
|
||||
-- selectOrphans :: QualificationId -> UTCTime -> DB [(LmsOrphanId, LmsIdent)]
|
||||
selectOrphans :: (MonadHandler m, HasAppSettings (HandlerSite m), BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
|
||||
=> Key Qualification -> UTCTime -> ReaderT backend m [(LmsOrphanId, LmsIdent)]
|
||||
selectOrphans qid now = do
|
||||
lmsConf <- getsYesod $ view _appLmsConf
|
||||
let cutoff_seen_first = addLocalDays (negate $ lmsConf ^. _lmsOrphanDeletionDays) now
|
||||
cutoff_deleted_last = addHours (negate $ lmsConf ^. _lmsOrphanRepeatHours) now
|
||||
cutoff_seen_last = cutoff_deleted_last
|
||||
orphan_max_batch = lmsConf ^. _lmsOrphanDeletionBatch
|
||||
$(E.unValueN 2) <<$>> (Ex.select $ do
|
||||
orv <- Ex.from $ Ex.table @LmsOrphan
|
||||
Ex.where_ $ Ex.val qid E.==. orv Ex.^. LmsOrphanQualification
|
||||
Ex.&&. E.hasLetter (orv Ex.^. LmsOrphanIdent) -- do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter
|
||||
Ex.&&. Ex.val cutoff_seen_first E.>=. orv Ex.^. LmsOrphanSeenFirst -- has been seen for while
|
||||
Ex.&&. Ex.val cutoff_seen_last E.<=. orv Ex.^. LmsOrphanSeenLast -- was still seen recently
|
||||
Ex.&&. Ex.val cutoff_deleted_last E.>~. orv Ex.^. LmsOrphanDeletedLast -- not already recently deleted
|
||||
Ex.&&. Ex.notExists (do -- not currently used anywhere (LmsIdent share the namespace)
|
||||
lusr <- Ex.from $ Ex.table @LmsUser
|
||||
Ex.where_ $ lusr Ex.^. LmsUserIdent E.==. orv Ex.^.LmsOrphanIdent
|
||||
)
|
||||
Ex.orderBy [Ex.desc $ orv Ex.^. LmsOrphanDeletedLast, Ex.asc $ orv Ex.^. LmsOrphanSeenLast] -- Note for PostgreSQL: DESC == DESC NULLS FIRST
|
||||
Ex.limit orphan_max_batch
|
||||
return (orv E.^. LmsOrphanId, orv E.^. LmsOrphanIdent)
|
||||
)
|
||||
|
||||
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
||||
getLmsLearnersDirectR sid qsh = do
|
||||
-- $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
||||
(lms_users, orphans, cutoff, qshs) <- runDB $ do
|
||||
(qid, cutoff) <- getQidCutoff sid qsh
|
||||
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
|
||||
let qids = qid : (entityKey <$> qidsReuse)
|
||||
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
|
||||
lms_users <- selectList [ LmsUserQualification <-. qids
|
||||
, LmsUserEnded ==. Nothing
|
||||
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
|
||||
] [Asc LmsUserStarted, Asc LmsUserIdent]
|
||||
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
|
||||
Ex.select $ do
|
||||
lmsuser <- Ex.from $ Ex.table @LmsUser
|
||||
Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
|
||||
Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
|
||||
pure $ LmsUserTableCsv
|
||||
{ csvLUTident = lmsuser Ex.^. LmsUserIdent
|
||||
, csvLUTpin = lmsuser Ex.^. LmsUserPin
|
||||
, csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
|
||||
, csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
|
||||
, csvLUTstaff = LmsBool False
|
||||
}
|
||||
-}
|
||||
now <- liftIO getCurrentTime
|
||||
orphans <- selectOrphans qid now
|
||||
updateWhere [LmsOrphanId <-. map fst orphans] [LmsOrphanDeletedLast =. Just now]
|
||||
return (lms_users, orphans, cutoff, qshs)
|
||||
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
|
||||
--csvRenderedHeader = lmsUserTableCsvHeader
|
||||
--cvsRendered = CsvRendered {..}
|
||||
csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . snd <$> orphans)
|
||||
fmtOpts = (review csvPreset CsvPresetRFC)
|
||||
{ csvIncludeHeader = lmsDownloadHeader
|
||||
, csvDelimiter = lmsDownloadDelimiter
|
||||
, csvUseCrLf = lmsDownloadCrLf
|
||||
}
|
||||
csvOpts = def { csvFormat = fmtOpts }
|
||||
csvSheetName <- csvFilenameLmsUser qsh
|
||||
let nr = length lms_users
|
||||
orv_nr = length orphans
|
||||
msg0 = "Success. LMS learners direct download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
|
||||
msg1 = ". Orphaned LMS idents marked for deletion: " <> tshow orv_nr
|
||||
msg = if orv_nr > 0 then msg0 <> msg1 else msg1
|
||||
$logInfoS "LMS" msg
|
||||
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
||||
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
|
||||
<* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "")
|
||||
-- direct Download see:
|
||||
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
||||
|
||||
|
||||
getLmsOrphansR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsOrphansR sid qsh = do
|
||||
orvTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
let
|
||||
orvDBTable = DBTable{..}
|
||||
where
|
||||
queryOrphan = id
|
||||
-- resultOrphan = _dbrOutput . _entityVal -- would need explicit type to work
|
||||
dbtSQLQuery orv = do
|
||||
E.where_ $ orv E.^. LmsOrphanQualification E.==. E.val qid
|
||||
return orv
|
||||
dbtRowKey = (E.^. LmsOrphanId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) -> textCell lid
|
||||
, sortable (Just "seen-first") (i18nCell MsgLmsOrphanSeenFirst) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst -> d) -> dateTimeCell d
|
||||
, sortable (Just "seen-last") (i18nCell MsgLmsOrphanSeenLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast -> d) -> dateTimeCell d
|
||||
, sortable (Just "deleted-last") (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast -> d) -> cellMaybe dateTimeCell d
|
||||
, sortable (Just "status") (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanResultLast -> s) -> lmsStateCell s
|
||||
, sortable (Just "reason") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> cellMaybe textCell t
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("ident" , SortColumn (E.^. LmsOrphanIdent))
|
||||
, ("seen-first" , SortColumn (E.^. LmsOrphanSeenFirst))
|
||||
, ("seen-last" , SortColumn (E.^. LmsOrphanSeenLast))
|
||||
, ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast))
|
||||
, ("status" , SortColumn (E.^. LmsOrphanResultLast))
|
||||
, ("reason" , SortColumn (E.^. LmsOrphanReason))
|
||||
]
|
||||
cachedNextOrphans = $(memcachedByHere) (Just $ Right $ 1 * diffMinute) ("cache-next-orphans" <> tshow qid) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
next_orphans <- runDBRead $ selectOrphans qid now -- only query next orphans when really needed; not sure how to formulate a proper sub-query here
|
||||
-- addMessageI Info $ MsgLmsOrphanNr $ length next_orphans -- debug
|
||||
return $ map fst next_orphans
|
||||
dbtFilter = Map.fromList
|
||||
[ ("ident" , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent))
|
||||
, ("reason" , FilterColumn $ E.mkContainsFilterWith Just (E.^. LmsOrphanReason))
|
||||
, ("preview" , FilterColumnHandler $ \case
|
||||
(x:_)
|
||||
| x == tshow True -> do
|
||||
next_orphans <- cachedNextOrphans
|
||||
return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.in_` E.valList next_orphans
|
||||
| x == tshow False -> do
|
||||
next_orphans <- cachedNextOrphans
|
||||
return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.notIn` E.valList next_orphans
|
||||
_ -> return (const E.true)
|
||||
)
|
||||
]
|
||||
-- checkBoxTextField = convertField show (\case { t | t == show True -> True; _ -> False }) checkBoxField -- UNNECESSARY hack to use FilterColumnHandler, which only works on [Text] criteria
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ -- prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here
|
||||
prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgLmsOrphanPreviewFltr)
|
||||
, prismAForm (singletonFilter "reason" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgLmsOrphanReason)
|
||||
, prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms-orphans"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
orvDBTableValidator = def & defaultSorting [SortAscBy "seen-first", SortDescBy "deleted-last"]
|
||||
snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget))
|
||||
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
siteLayoutMsg MsgLmsOrphans $ do
|
||||
setTitleI MsgLmsOrphans
|
||||
$(i18nWidgetFile "lms-orphans")
|
||||
@ -1,396 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.MailCenter
|
||||
( getMailCenterR, postMailCenterR
|
||||
, getMailHtmlR
|
||||
, getMailPlainR
|
||||
, getMailAttachmentR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Aeson as Aeson
|
||||
-- import qualified Data.Text as Text
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
|
||||
-- import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
|
||||
import Numeric (readHex)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
data MCTableAction = MCActResendEmail
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe MCTableAction
|
||||
instance Finite MCTableAction
|
||||
nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''MCTableAction id
|
||||
|
||||
newtype MCTableActionData = MCActResendEmailData UserEmail
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler ()
|
||||
resendMailTo recv smids = do
|
||||
(recvName, mails) <- runDBRead $ (,)
|
||||
<$> (userDisplayName . entityVal <<$>> getByFilter ([UserEmail ==. recv] ||. [UserDisplayEmail ==. recv]))
|
||||
<*> E.select (do
|
||||
(sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId)
|
||||
E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids
|
||||
return (sm, smc)
|
||||
)
|
||||
forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do
|
||||
let mailParts = getMailContent content
|
||||
mailTo = []
|
||||
mailCc = []
|
||||
mailBcc = [Address{addressName = recvName, addressEmail = ciOriginal recv}]
|
||||
mailFrom = error "Handler.MailCenter.resenMailTo: mailFrom not replaced by sendSimpleMail" -- :: Address -- will be filled in later by sendSimpleMail
|
||||
mailHeaders = toHeaders sentMailHeaders -- :: Headers -- keep as it was? Includes To/Cc/Bcc
|
||||
sendSimpleMail Mail{..}
|
||||
|
||||
|
||||
type MCTableExpr =
|
||||
( E.SqlExpr (Entity SentMail)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
)
|
||||
|
||||
queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
|
||||
queryMail = $(sqlLOJproj 2 1)
|
||||
|
||||
|
||||
queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipient = $(sqlLOJproj 2 2)
|
||||
|
||||
|
||||
type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
|
||||
|
||||
resultMail :: Lens' MCTableData (Entity SentMail)
|
||||
resultMail = _dbrOutput . _1
|
||||
|
||||
resultRecipient :: Traversal' MCTableData (Entity User)
|
||||
resultRecipient = _dbrOutput . _2 . _Just
|
||||
|
||||
|
||||
mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
|
||||
mkMCTable = do
|
||||
let
|
||||
dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
|
||||
dbtSQLQuery (mail `E.LeftOuterJoin` recipient) = do
|
||||
EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
|
||||
return (mail, recipient)
|
||||
dbtRowKey = queryMail >>> (E.^. SentMailId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = mconcat
|
||||
[ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
|
||||
sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
|
||||
let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
|
||||
linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
|
||||
in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
|
||||
-- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
|
||||
-- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
|
||||
, ("recipient" , sortUserNameBareM queryRecipient)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ ("sentTo" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt))
|
||||
, ("sentFrom" , FilterColumn . E.mkDayFilterFrom $ views (to queryMail) (E.^. SentMailSentAt))
|
||||
, ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
-- , ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
, ("content" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
|
||||
body <- E.from $ E.table @SentMailContent
|
||||
E.where_ $ body E.^. SentMailContentId E.==. queryMail row E.^. SentMailContentRef
|
||||
E.&&. E.mailContentContains (body E.^. SentMailContentContent) (E.val criterion)
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "sentTo" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentBefore)
|
||||
, prismAForm (singletonFilter "sentFrom" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentAfter)
|
||||
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
|
||||
-- , prismAForm (singletonFilter "regex" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject )
|
||||
, prismAForm (singletonFilter "content" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommContent) -- & setTooltip MsgCommContentSearch)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "sent-mail"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional
|
||||
= let acts :: Map MCTableAction (AForm Handler MCTableActionData)
|
||||
acts = mconcat
|
||||
[ singletonMap MCActResendEmail $ MCActResendEmailData
|
||||
<$> areq (emailField & cfStrip & cfCI) (fslI MsgMCActResendEmail & setTooltip MsgMCActResendEmailTooltip) Nothing
|
||||
]
|
||||
in renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
|
||||
-> FormResult ( MCTableActionData, Set SentMailId)
|
||||
postprocess inp = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortDescBy "sent"]
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
|
||||
getMailCenterR, postMailCenterR :: Handler Html
|
||||
getMailCenterR = postMailCenterR
|
||||
postMailCenterR = do
|
||||
(mcRes, mcTable) <- runDB mkMCTable
|
||||
formResult mcRes $ \case
|
||||
(MCActResendEmailData recv, smIds) -> do
|
||||
resendMailTo recv smIds
|
||||
addMessageI (bool Success Error $ null smIds) $ MsgMCActResendEmailInfo (Set.size smIds) (ciOriginal recv)
|
||||
reloadKeepGetParams MailCenterR
|
||||
siteLayoutMsg MsgMenuMailCenter $ do
|
||||
setTitleI MsgMenuMailCenter
|
||||
$(widgetFile "mail-center")
|
||||
|
||||
|
||||
typePDF :: ContentType
|
||||
typePDF = "application/pdf"
|
||||
|
||||
getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
|
||||
getMailAttachmentR cusm attdisp = do
|
||||
smid <- decrypt cusm
|
||||
(sm,cn) <- runDBRead $ do
|
||||
sm <- get404 smid
|
||||
cn <- get404 $ sm ^. _sentMailContentRef
|
||||
return (sm,cn)
|
||||
let mcontent = getMailContent (sentMailContentContent cn)
|
||||
getAttm alts = case selectAlternative [typePDF] alts of
|
||||
(Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
|
||||
| t == attdisp
|
||||
-> Just pc
|
||||
_ -> Nothing
|
||||
attm = firstJust getAttm mcontent
|
||||
case attm of
|
||||
(Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
|
||||
_ -> notFound
|
||||
|
||||
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailHtmlR = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain]
|
||||
|
||||
getMailPlainR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailPlainR = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]
|
||||
|
||||
handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
|
||||
handleMailShow hdr prefTypes cusm = do
|
||||
smid <- decrypt cusm
|
||||
(sm,cn) <- runDBRead $ do
|
||||
sm <- get404 smid
|
||||
cn <- get404 $ sm ^. _sentMailContentRef
|
||||
return (sm,cn)
|
||||
siteLayout' Nothing $ do
|
||||
setTitleI hdr
|
||||
let mcontent = getMailContent (sentMailContentContent cn)
|
||||
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
|
||||
mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
|
||||
[whamlet|
|
||||
<section>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintJobCreated}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
|
||||
$maybe usr <- sm ^. _sentMailRecipient
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintRecipient}
|
||||
<dd .deflist__dd>
|
||||
^{userIdWidget usr}
|
||||
$maybe r <- getHeader "To"
|
||||
<dt .deflist__dt>
|
||||
To
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
$maybe r <- getHeader "Cc"
|
||||
<dt .deflist__dt>
|
||||
Cc
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
$maybe r <- getHeader "From"
|
||||
<dt .deflist__dt>
|
||||
From
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
$maybe r <- getHeader "Subject"
|
||||
<dt .deflist__dt>
|
||||
_{MsgCommSubject}
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
|
||||
<section>
|
||||
$forall pt <- mparts
|
||||
^{part2widget cusm pt}
|
||||
|]
|
||||
-- Include for Debugging:
|
||||
-- <section>
|
||||
-- <h2>Debugging
|
||||
-- <p>
|
||||
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
||||
-- <p>
|
||||
-- ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
|
||||
|
||||
selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
|
||||
selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
|
||||
where
|
||||
aux ts@(ct:_) (pt:ps)
|
||||
| ct == partType pt = Just pt
|
||||
| otherwise = aux ts ps
|
||||
aux (_:ts) [] = aux ts allAlts
|
||||
aux [] (pt:_) = Just pt
|
||||
aux _ [] = Nothing
|
||||
|
||||
reorderParts :: [Part] -> [Part]
|
||||
reorderParts = sortBy pOrder
|
||||
where
|
||||
pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
|
||||
|
||||
dispoOrder DefaultDisposition DefaultDisposition = EQ
|
||||
dispoOrder DefaultDisposition _ = LT
|
||||
dispoOrder _ DefaultDisposition = GT
|
||||
dispoOrder (InlineDisposition t1) (InlineDisposition t2) = compare t1 t2
|
||||
dispoOrder (InlineDisposition _) _ = LT
|
||||
dispoOrder _ (InlineDisposition _) = GT
|
||||
dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
|
||||
|
||||
disposition2widget :: Disposition -> Widget
|
||||
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
|
||||
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
|
||||
disposition2widget DefaultDisposition = mempty
|
||||
|
||||
part2widget :: CryptoUUIDSentMail -> Part -> Widget
|
||||
part2widget cusm Part{partContent=NestedParts ps} =
|
||||
[whamlet|
|
||||
$forall p <- ps
|
||||
^{part2widget cusm p}
|
||||
|]
|
||||
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
|
||||
[whamlet|
|
||||
<section>
|
||||
^{disposition2widget dispo}
|
||||
^{showBody}
|
||||
^{showPass}
|
||||
|]
|
||||
where
|
||||
showBody
|
||||
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
|
||||
| pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
|
||||
| pt == decodeUtf8 typeJson =
|
||||
let jw :: Aeson.Value -> Widget = jsonWidget
|
||||
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
|
||||
| pt == decodeUtf8 typePDF
|
||||
, AttachmentDisposition t <- dispo
|
||||
= [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
|
||||
| otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
|
||||
showPass
|
||||
| pt == decodeUtf8 typePlain
|
||||
, let cw = T.words $ decodeUtf8 pc
|
||||
, Just name <- listBracket ("Inhaber","Gültig") cw -- heursitic for dirving licence renewal letters only; improve
|
||||
<|> listBracket ("Licensee","Valid") cw
|
||||
= let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
|
||||
liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
|
||||
Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
|
||||
Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
|
||||
[whamlet|
|
||||
<section>
|
||||
$maybe pw <- mbpw
|
||||
<details>
|
||||
<summary>
|
||||
_{MsgAdminUserPinPassword}
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
^{userWidget u}
|
||||
<dd .deflist__dd>
|
||||
<b>
|
||||
#{pw}
|
||||
<p>
|
||||
_{MsgAdminUserPinPassNotIncluded}
|
||||
$nothing
|
||||
_{MsgAdminUserNoPassword}
|
||||
|]
|
||||
| otherwise = mempty
|
||||
|
||||
------------------------------
|
||||
-- Decode MIME Encoded Word
|
||||
|
||||
-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
|
||||
decodeEncodedWord :: Text -> Text
|
||||
decodeEncodedWord tinp
|
||||
| (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp
|
||||
, (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf
|
||||
, notNull cw
|
||||
= pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm
|
||||
| otherwise
|
||||
= tinp
|
||||
|
||||
decodeEncodedWordHeader :: Text -> Text
|
||||
decodeEncodedWordHeader tinp
|
||||
| [enc, bin, cw] <- T.splitOn "?" tinp
|
||||
, "utf-8" == T.toLower enc
|
||||
, "Q" == T.toUpper bin -- Quoted Printable Text
|
||||
= decEncWrdUtf8Q cw
|
||||
-- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment
|
||||
| otherwise
|
||||
= tinp
|
||||
|
||||
decEncWrdUtf8Q :: Text -> Text
|
||||
decEncWrdUtf8Q tinp
|
||||
| Right ok <- TE.decodeUtf8' $ decWds tinp
|
||||
= ok
|
||||
| otherwise
|
||||
= tinp
|
||||
where
|
||||
decWds :: Text -> S.ByteString
|
||||
decWds t
|
||||
| (h:tl) <- T.splitOn "=" t
|
||||
= mconcat $ TE.encodeUtf8 h : map deco tl
|
||||
| otherwise
|
||||
= TE.encodeUtf8 t
|
||||
|
||||
deco :: Text -> S.ByteString
|
||||
deco w
|
||||
| (c,r) <- T.splitAt 2 w
|
||||
, [(v,"")] <- readHex $ T.unpack c
|
||||
= S.cons v $ TE.encodeUtf8 r
|
||||
| otherwise
|
||||
= TE.encodeUtf8 w
|
||||
@ -1,115 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2025 Steffen Jost <S.Jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Qualification.Edit
|
||||
( getQualificationNewR, postQualificationNewR
|
||||
, getQualificationEditR, postQualificationEditR
|
||||
)
|
||||
where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import Handler.Utils
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
-- import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
|
||||
|
||||
getQualificationNewR, postQualificationNewR :: SchoolId -> Handler Html
|
||||
getQualificationNewR = postQualificationNewR
|
||||
postQualificationNewR ssh = handleQualificationEdit ssh Nothing
|
||||
|
||||
getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getQualificationEditR = postQualificationEditR
|
||||
postQualificationEditR ssh qsh = do
|
||||
qent <- runDBRead $ getBy404 $ SchoolQualificationShort ssh qsh
|
||||
handleQualificationEdit ssh $ Just qent
|
||||
|
||||
|
||||
mkQualificationForm :: SchoolId -> Maybe Qualification -> Form Qualification
|
||||
mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm (validateQualificationEdit ssh) $ \html ->
|
||||
flip (renderAForm FormStandard) html $ reorderedQualification
|
||||
<$> areq hiddenField "" (Just ssh) -- 1 -> 1
|
||||
<*> areq ciField (fslI MsgQualificationShort) (qualificationShorthand <$> templ) -- 2 -> 2
|
||||
<*> areq ciField (fslI MsgQualificationName) (qualificationName <$> templ) -- 3 -> 3
|
||||
<*> aopt htmlField (fslI MsgQualificationDescription) (qualificationDescription <$> templ) -- 4 -> 4
|
||||
<*> aopt_natFieldI MsgQualificationValidDuration (qualificationValidDuration <$> templ) -- 5 -> 5
|
||||
<*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshWithin &
|
||||
setTooltip MsgQualificationRefreshWithinTooltip) (qualificationRefreshWithin <$> templ) -- 6 -> 7
|
||||
|
||||
<*> areq checkBoxField (fslI MsgQualificationElearningStart) (qualificationElearningStart <$> templ) -- 7 -> 9
|
||||
<*> aopt calendarDiffDaysField (fslI MsgQualificationRefreshReminder &
|
||||
setTooltip MsgQualificationRefreshReminderTooltip) (qualificationRefreshReminder <$> templ) -- 8 -> 8
|
||||
<*> areq checkBoxField (fslI MsgQualificationExpiryNotification) (qualificationExpiryNotification <$> templ) -- 9 -> 13
|
||||
<*> areq_natFieldI MsgQualificationAuditDuration (qualificationAuditDuration <$> templ) -- 10 -> 6
|
||||
<*> areq checkBoxField (fslI MsgQualificationElearningRenew) (qualificationElearningRenews <$> templ) -- 11 -> 10
|
||||
<*> aopt_natFieldI MsgQualificationElearningLimit (qualificationElearningLimit <$> templ) -- 12 -> 11
|
||||
<*> aopt qualificationField (fslI MsgTableQualificationLmsReuses &
|
||||
setTooltip MsgTableQualificationLmsReusesTooltip) (qualificationLmsReuses <$> templ) -- 13 -> 12
|
||||
<*> aopt avsLicenceField (fslI MsgQualificationAvsLicence &
|
||||
setTooltip MsgTableQualificationIsAvsLicenceTooltip) (qualificationAvsLicence <$> templ) -- 14 -> 14
|
||||
<*> aopt textField (fslI MsgQualificationSapId &
|
||||
setTooltip MsgTableQualificationSapExportTooltip) (qualificationSapId <$> templ) -- 15 -> 15
|
||||
where
|
||||
avsLicenceField :: Field Handler AvsLicence
|
||||
avsLicenceField = selectFieldList [ (Text.singleton $ licence2char lic, lic) | lic <- universeF, lic /= AvsNoLicence ]
|
||||
|
||||
aopt_natFieldI msg = aopt (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg)
|
||||
areq_natFieldI msg = areq (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg)
|
||||
-- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15]
|
||||
reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification -- == inversePermutation [1,2,3,4,5,7,9,8,13,6,10,11,12,14,15]
|
||||
|
||||
validateQualificationEdit :: SchoolId -> FormValidator Qualification Handler ()
|
||||
validateQualificationEdit ssh = do
|
||||
canonise
|
||||
Qualification{..} <- State.get
|
||||
guardValidation MsgQualFormErrorSshMismatch $ qualificationSchool == ssh
|
||||
guardValidation MsgLmsErrorNoRefreshElearning $ not qualificationElearningStart || isJust qualificationRefreshWithin
|
||||
guardValidation MsgLmsErrorNoRenewElearning $ not qualificationElearningStart || isJust qualificationValidDuration
|
||||
when (isJust qualificationLmsReuses) $
|
||||
liftHandler $ addMessageI Info MsgQualificationAuditDurationReuseInfo
|
||||
where
|
||||
canonise = do -- i.e. map Just 0 to Nothing
|
||||
Qualification{..} <- State.get
|
||||
-- canonisation, i.e. map Just 0 to Nothing
|
||||
when (qualificationRefreshWithin == Just mempty) $ State.modify $ set _qualificationRefreshWithin Nothing
|
||||
when (qualificationRefreshReminder == Just mempty) $ State.modify $ set _qualificationRefreshReminder Nothing
|
||||
when (qualificationValidDuration == Just 0) $ State.modify $ set _qualificationValidDuration Nothing
|
||||
when (qualificationElearningLimit == Just 0) $ State.modify $ set _qualificationElearningLimit Nothing
|
||||
|
||||
|
||||
|
||||
handleQualificationEdit :: SchoolId -> Maybe (Entity Qualification) -> Handler Html
|
||||
handleQualificationEdit ssh templ = do
|
||||
((qRes, qWgt), qEnc) <- runFormPost $ mkQualificationForm ssh $ entityVal <$> templ
|
||||
let qForm = wrapForm qWgt def
|
||||
{ formEncoding = qEnc
|
||||
}
|
||||
formResult qRes $ \resQuali -> do
|
||||
uniqViolation <- runDB $ case templ of
|
||||
Just Entity{entityKey=qid} -> replaceUnique qid resQuali -- edit old qualification
|
||||
_ -> maybeM (checkUnique resQuali) (const $ return Nothing) (insertUnique resQuali) -- insert new qualification
|
||||
case uniqViolation of
|
||||
Just (SchoolQualificationShort _ nconflict) -> addMessageI Error $ MsgQualFormErrorDuplShort $ ciOriginal nconflict
|
||||
Just (SchoolQualificationName _ nconflict) -> addMessageI Error $ MsgQualFormErrorDuplName $ ciOriginal nconflict
|
||||
Nothing -> do
|
||||
let qshort = qualificationShorthand resQuali
|
||||
qmsg = if isNothing templ then MsgQualificationCreated else MsgQualificationEdit
|
||||
addMessageI Success $ qmsg $ ciOriginal qshort
|
||||
redirect $ QualificationR ssh qshort
|
||||
let heading = bool MsgMenuQualificationNew MsgMenuQualificationEdit $ isJust templ
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
[whamlet|
|
||||
<p>
|
||||
^{qForm}
|
||||
$maybe _ <- templ
|
||||
<p>
|
||||
_{MsgQualificationEditNote}
|
||||
|]
|
||||
@ -1,877 +0,0 @@
|
||||
|
||||
-- SPDX-FileCopyrightText: 2024-2025 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Handler.School.DayTasks
|
||||
( getSchoolDayR, postSchoolDayR
|
||||
, getSchoolDayCheckR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Company
|
||||
-- import Handler.Utils.Occurrences
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Course.Cache
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import Database.Esqueleto.PostgreSQL.JSON ((@>.))
|
||||
-- import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
|
||||
-- | Maximal number of suggestions for note fields in Day Task view
|
||||
maxSuggestions :: Int64
|
||||
maxSuggestions = 7
|
||||
|
||||
-- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
|
||||
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
-- instance Universe DailyTableAction
|
||||
-- instance Finite DailyTableAction
|
||||
-- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
|
||||
-- embedRenderMessage ''UniWorX ''DailyTableAction id
|
||||
|
||||
-- data DailyTableActionData = DailyActDummyData
|
||||
-- deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
type DailyTableExpr =
|
||||
( E.SqlExpr (Entity Course)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Tutorial)
|
||||
`E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserDay))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity TutorialParticipantDay))
|
||||
)
|
||||
|
||||
type DailyTableOutput = E.SqlQuery
|
||||
( E.SqlExpr (Entity Course)
|
||||
, E.SqlExpr (Entity Tutorial)
|
||||
, E.SqlExpr (Entity TutorialParticipant)
|
||||
, E.SqlExpr (Entity User)
|
||||
, E.SqlExpr (Maybe (Entity UserAvs))
|
||||
, E.SqlExpr (Maybe (Entity UserDay))
|
||||
, E.SqlExpr (Maybe (Entity TutorialParticipantDay))
|
||||
, E.SqlExpr (E.Value (Maybe CompanyId))
|
||||
, E.SqlExpr (E.Value (Maybe [QualificationId]))
|
||||
)
|
||||
|
||||
type DailyTableData = DBRow
|
||||
( Entity Course
|
||||
, Entity Tutorial
|
||||
, Entity TutorialParticipant
|
||||
, Entity User
|
||||
, Maybe (Entity UserAvs)
|
||||
, Maybe (Entity UserDay)
|
||||
, Maybe (Entity TutorialParticipantDay)
|
||||
, E.Value (Maybe CompanyId)
|
||||
, E.Value (Maybe [QualificationId])
|
||||
)
|
||||
|
||||
data DailyFormData = DailyFormData
|
||||
{ dailyFormDrivingPermit :: Maybe UserDrivingPermit
|
||||
, dailyFormEyeExam :: Maybe UserEyeExam
|
||||
, dailyFormParticipantNote :: Maybe Text
|
||||
, dailyFormAttendance :: Bool
|
||||
, dailyFormAttendanceNote :: Maybe Text
|
||||
, dailyFormParkingToken :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
makeLenses_ ''DailyFormData
|
||||
|
||||
-- force declarations before this point to avoid staging restrictions
|
||||
$(return [])
|
||||
|
||||
|
||||
queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
|
||||
queryCourse = $(sqlMIXproj' ''DailyTableExpr 1)
|
||||
|
||||
queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
|
||||
queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2)
|
||||
|
||||
queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
|
||||
queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3)
|
||||
-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) -- reify seems problematic for now
|
||||
|
||||
queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlMIXproj' ''DailyTableExpr 4)
|
||||
|
||||
queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs))
|
||||
queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5)
|
||||
|
||||
queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay))
|
||||
queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6)
|
||||
|
||||
queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay))
|
||||
queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7)
|
||||
|
||||
resultCourse :: Lens' DailyTableData (Entity Course)
|
||||
resultCourse = _dbrOutput . _1
|
||||
|
||||
resultTutorial :: Lens' DailyTableData (Entity Tutorial)
|
||||
resultTutorial = _dbrOutput . _2
|
||||
|
||||
resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
|
||||
resultParticipant = _dbrOutput . _3
|
||||
|
||||
resultUser :: Lens' DailyTableData (Entity User)
|
||||
resultUser = _dbrOutput . _4
|
||||
|
||||
resultUserAvs :: Traversal' DailyTableData UserAvs
|
||||
resultUserAvs = _dbrOutput . _5 . _Just . _entityVal
|
||||
|
||||
resultUserDay :: Traversal' DailyTableData UserDay
|
||||
resultUserDay = _dbrOutput . _6 . _Just . _entityVal
|
||||
|
||||
resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay
|
||||
resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal
|
||||
|
||||
resultCompanyId :: Traversal' DailyTableData CompanyId
|
||||
resultCompanyId = _dbrOutput . _8 . _unValue . _Just
|
||||
|
||||
resultCourseQualis :: Traversal' DailyTableData [QualificationId]
|
||||
resultCourseQualis = _dbrOutput . _9 . _unValue . _Just
|
||||
|
||||
|
||||
instance HasEntity DailyTableData User where
|
||||
hasEntity = resultUser
|
||||
|
||||
instance HasUser DailyTableData where
|
||||
hasUser = resultUser . _entityVal
|
||||
|
||||
-- see colRatedField' for an example of formCell usage
|
||||
|
||||
drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit
|
||||
drivingPermitField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite
|
||||
|
||||
eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam
|
||||
eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite
|
||||
|
||||
mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell
|
||||
id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
|
||||
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
|
||||
(\(view lg -> x) mkUnique ->
|
||||
over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x)
|
||||
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
||||
|
||||
colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit
|
||||
|
||||
colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
||||
colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell
|
||||
id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
|
||||
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
|
||||
(\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique ->
|
||||
over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit" & addClass' "uwx-narrow") (Just x)
|
||||
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
||||
|
||||
colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam
|
||||
|
||||
colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
||||
colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id
|
||||
(views (resultParticipant . _entityKey) return)
|
||||
(\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique ->
|
||||
over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam" & addClass' "uwx-narrow") (Just x)
|
||||
)
|
||||
|
||||
-- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
-- colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
||||
-- (views (resultParticipant . _entityKey) return)
|
||||
-- (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique ->
|
||||
-- over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
|
||||
-- mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note)
|
||||
-- )
|
||||
|
||||
colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","min-width:12em")]) <$>
|
||||
formCell id
|
||||
(views (resultParticipant . _entityKey) return)
|
||||
(\row mkUnique ->
|
||||
let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote
|
||||
sid = row ^. resultCourse . _entityVal . _courseSchool
|
||||
cid = row ^. resultCourse . _entityKey
|
||||
tid = row ^. resultTutorial . _entityKey
|
||||
in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$>
|
||||
mopt (textField & cfStrip & addDatalist (suggsParticipantNote sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
|
||||
)
|
||||
|
||||
suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
|
||||
suggsParticipantNote sid cid tid = do
|
||||
ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsParticipantNote sid tid) $ do
|
||||
suggs <- runDB $ E.select $ do
|
||||
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||
(tpn, prio) <- E.from $
|
||||
( do
|
||||
tpa <- E.from $ E.table @TutorialParticipant
|
||||
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
|
||||
E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid
|
||||
E.groupBy $ tpa E.^. TutorialParticipantNote
|
||||
E.orderBy [E.desc countRows']
|
||||
E.limit maxSuggestions
|
||||
pure (tpa E.^. TutorialParticipantNote, E.val (1 :: Int64))
|
||||
) `E.unionAll_`
|
||||
( do
|
||||
(tpa :& tut) <- E.from $ E.table @TutorialParticipant
|
||||
`E.innerJoin` E.table @Tutorial
|
||||
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
|
||||
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
|
||||
E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
|
||||
E.&&. tut E.^. TutorialCourse E.==. E.val cid
|
||||
E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
|
||||
E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
|
||||
E.limit maxSuggestions
|
||||
pure (tpa E.^. TutorialParticipantNote, E.val 2)
|
||||
) `E.unionAll_`
|
||||
( do
|
||||
tpa :& tut :& crs <- E.from $ E.table @TutorialParticipant
|
||||
`E.innerJoin` E.table @Tutorial
|
||||
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
|
||||
`E.innerJoin` E.table @Course
|
||||
`E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
|
||||
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
|
||||
E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
|
||||
E.&&. tut E.^. TutorialCourse E.!=. E.val cid
|
||||
E.&&. crs E.^. CourseSchool E.==. E.val sid
|
||||
E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
|
||||
E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
|
||||
E.limit maxSuggestions
|
||||
pure (tpa E.^. TutorialParticipantNote, E.val 3)
|
||||
)
|
||||
E.groupBy (tpn, prio)
|
||||
E.orderBy [E.asc prio, E.asc tpn]
|
||||
E.limit maxSuggestions
|
||||
pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type
|
||||
-- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs
|
||||
pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs
|
||||
-- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol
|
||||
pure $ mkOptionListFromCacheable ol
|
||||
|
||||
suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
|
||||
suggsAttendanceNote sid cid tid = do
|
||||
ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do
|
||||
suggs <- runDB $ E.select $ do
|
||||
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||
(tpn, prio) <- E.from $
|
||||
( do
|
||||
tpa <- E.from $ E.table @TutorialParticipantDay
|
||||
E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
|
||||
E.&&. tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid
|
||||
E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay)
|
||||
E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
|
||||
E.limit maxSuggestions
|
||||
pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64))
|
||||
) `E.unionAll_`
|
||||
( do
|
||||
(tpa :& tut) <- E.from $ E.table @TutorialParticipantDay
|
||||
`E.innerJoin` E.table @Tutorial
|
||||
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
|
||||
E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
|
||||
E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
|
||||
E.&&. tut E.^. TutorialCourse E.==. E.val cid
|
||||
E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged)
|
||||
E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
|
||||
E.limit maxSuggestions
|
||||
pure (tpa E.^. TutorialParticipantDayNote, E.val 2)
|
||||
) `E.unionAll_`
|
||||
( do
|
||||
tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay
|
||||
`E.innerJoin` E.table @Tutorial
|
||||
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
|
||||
`E.innerJoin` E.table @Course
|
||||
`E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
|
||||
E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
|
||||
E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
|
||||
E.&&. tut E.^. TutorialCourse E.!=. E.val cid
|
||||
E.&&. crs E.^. CourseSchool E.==. E.val sid
|
||||
E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged)
|
||||
E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
|
||||
E.limit maxSuggestions
|
||||
pure (tpa E.^. TutorialParticipantDayNote, E.val 3)
|
||||
)
|
||||
E.groupBy (tpn, prio)
|
||||
E.orderBy [E.asc prio, E.asc tpn]
|
||||
E.limit maxSuggestions
|
||||
pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type
|
||||
pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- NOTE: datalist does not work on textarea inputs
|
||||
pure $ mkOptionListFromCacheable ol
|
||||
|
||||
|
||||
colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id
|
||||
(views (resultParticipant . _entityKey) return)
|
||||
(\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
|
||||
over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
|
||||
)
|
||||
|
||||
colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","min-width:12em")]) <$>
|
||||
formCell id
|
||||
(views (resultParticipant . _entityKey) return)
|
||||
(\row mkUnique ->
|
||||
let note = row ^? resultParticipantDay . _tutorialParticipantDayNote
|
||||
sid = row ^. resultCourse . _entityVal . _courseSchool
|
||||
cid = row ^. resultCourse . _entityKey
|
||||
tid = row ^. resultTutorial . _entityKey
|
||||
in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> -- For Textarea use: fmap (Text.strip . unTextarea)
|
||||
mopt (textField & cfStrip & addDatalist (suggsAttendanceNote sid cid tid)) (fsUniq mkUnique "note-attendance") note
|
||||
---- Version für Textare
|
||||
-- mopt (textareaField) -- & addDatalist (suggsAttendanceNote sid cid tid)) -- NOTE: datalist does not work on textarea inputs
|
||||
-- (fsUniq mkUnique "note-attendance" & addClass' "uwx-short"
|
||||
-- -- & addAttr "rows" "2" -- does not work without class uwx-short
|
||||
-- -- & addAttr "cols" "12" -- let it stretch
|
||||
-- -- & addAutosubmit -- submits while typing
|
||||
-- ) (Textarea <<$>> note)
|
||||
)
|
||||
|
||||
colParkingField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
||||
colParkingField = colParkingField' _dailyFormParkingToken
|
||||
|
||||
-- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
||||
-- colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id
|
||||
-- (views (resultParticipant . _entityKey) return)
|
||||
-- (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
|
||||
-- over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
|
||||
-- )
|
||||
|
||||
colParkingField' :: ASetter' a Bool -> Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
||||
colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserParkingToken dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell
|
||||
id -- TODO: this should not be id! Refactor to simplify the third argument below
|
||||
(views (resultParticipant . _entityKey) return)
|
||||
(\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
|
||||
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
|
||||
)
|
||||
|
||||
mkDailyTable :: Bool -> SchoolId -> Day -> Maybe DayCheckResults -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget)
|
||||
mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case
|
||||
tutLessons
|
||||
| Map.null tutLessons -> return (FormMissing, Nothing)
|
||||
| otherwise -> do
|
||||
dday <- formatTime SelFormatDate nd
|
||||
let
|
||||
tutIds = Map.keys tutLessons
|
||||
dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
|
||||
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
|
||||
EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial
|
||||
E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser
|
||||
E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay
|
||||
EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser
|
||||
E.&&. E.val nd E.=?. udy E.?. UserDayDay
|
||||
EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
|
||||
EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
|
||||
EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
|
||||
EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
|
||||
E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
|
||||
let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
|
||||
E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
|
||||
let cqQual = cq E.^. CourseQualificationQualification
|
||||
cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
|
||||
return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
|
||||
return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
|
||||
dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
|
||||
sortable (Just "course") (i18nCell MsgTableCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
|
||||
, sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row ->
|
||||
let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
|
||||
= row ^. resultCourse . _entityVal
|
||||
tutName = row ^. resultTutorial . _entityVal . _tutorialName
|
||||
in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
|
||||
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False . snd) $ Map.lookup tutId tutLessons
|
||||
, sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
|
||||
-- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
|
||||
cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ snd <$> Map.lookup tutId tutLessons
|
||||
-- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
|
||||
, sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
|
||||
-- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
|
||||
-- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
|
||||
, sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row ->
|
||||
let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
|
||||
primComp = row ^? resultCompanyId
|
||||
bookLink = cellMaybe companyIdCell bookComp
|
||||
result
|
||||
| primComp /= bookComp
|
||||
, Just (unCompanyKey -> csh) <- primComp
|
||||
= cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
|
||||
(Just IconCompany) True)
|
||||
<> spacerCell
|
||||
<> bookLink
|
||||
| otherwise = bookLink
|
||||
in result
|
||||
-- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row ->
|
||||
-- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
|
||||
-- primComp = row ^? resultCompanyId
|
||||
-- bookLink = cellMaybe companyIdCell bookComp
|
||||
-- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True
|
||||
-- result
|
||||
-- | primComp /= bookComp
|
||||
-- , Just (unCompanyKey -> csh) <- primComp
|
||||
-- = bookLink
|
||||
-- <> spacerCell
|
||||
-- <> cell (modal (warnIcon csh) (Right -- maybe just use iconCompanyWarning instead of modal?
|
||||
-- [whamlet|
|
||||
-- <h2>
|
||||
-- ^{userWidget row}
|
||||
-- <p>
|
||||
-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
|
||||
-- |]
|
||||
-- ))
|
||||
-- | otherwise = bookLink
|
||||
-- in result
|
||||
, maybeEmpty dcrs $ \DayCheckResults{..} ->
|
||||
sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) ->
|
||||
maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widgetIcn Nothing
|
||||
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
|
||||
, colUserMatriclenr isAdmin
|
||||
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
|
||||
, colParticipantEyeExamField
|
||||
, colParticipantPermitField
|
||||
, colParticipantNoteField
|
||||
, colAttendanceField dday
|
||||
, colAttendanceNoteField dday
|
||||
, colParkingField dday
|
||||
-- FOR DEBUGGING ONLY:
|
||||
-- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
|
||||
-- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell
|
||||
-- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell
|
||||
-- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell
|
||||
-- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell
|
||||
-- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser
|
||||
, sortUserMatriclenr queryUser
|
||||
, ("course" , SortColumn $ queryCourse >>> (E.^. CourseName))
|
||||
, ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
|
||||
, ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
|
||||
, ("booking-firm" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
|
||||
, ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
|
||||
, ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
|
||||
, ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
|
||||
, ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote))
|
||||
, ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
|
||||
, ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
|
||||
, ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
|
||||
-- , ("check-fail" , SortColumn $ queryParticipant >>> (\pid -> pid E.^. TutorialParticipantId `E.in_` E.vals (maybeEmpty dcrs $ dcrResults >>> Map.keys)))
|
||||
, let dcrsLevels = maybeEmpty dcrs $ dcrSeverityGroups . dcrResults in
|
||||
("check-fail" , SortColumn $ queryParticipant >>> (\((E.^. TutorialParticipantId) -> pid) -> E.case_
|
||||
[ E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _1)) E.then_ (E.val 1)
|
||||
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _2)) E.then_ (E.val 2)
|
||||
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _3)) E.then_ (E.val 3)
|
||||
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _4)) E.then_ (E.val 4)
|
||||
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _5)) E.then_ (E.val 5)
|
||||
] (E.else_ E.val (99 :: Int64))
|
||||
))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
, fltrUserMatriclenr queryUser
|
||||
, ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
|
||||
, ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
|
||||
, ("booking-firm" , FilterColumn . E.mkContainsFilterWith Just $ queryParticipant >>> (E.^. TutorialParticipantCompany))
|
||||
, ("user-company" , FilterColumn . E.mkContainsFilterWith Just $ queryUser >>> selectCompanyUserPrime)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse)
|
||||
, prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial)
|
||||
, prismAForm (singletonFilter "booking-firm" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableBookingCompanyShort)
|
||||
, prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompanyShort)
|
||||
, fltrUserNameEmailUI mPrev
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "daily"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
|
||||
-- dbtParams = DBParamsForm
|
||||
-- { dbParamsFormMethod = POST
|
||||
-- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
||||
-- , dbParamsFormAttrs = []
|
||||
-- , dbParamsFormSubmit = FormSubmit
|
||||
-- , dbParamsFormAdditional = \frag -> do
|
||||
-- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
|
||||
-- acts = mconcat
|
||||
-- [ singletonMap DailyActDummy $ pure DailyActDummyData
|
||||
-- ]
|
||||
-- (actionRes, action) <- multiActionM acts "" Nothing mempty
|
||||
-- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
||||
-- -- , dbParamsFormAdditional
|
||||
-- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
|
||||
-- -- acts = mconcat
|
||||
-- -- [ singletonMap DailyActDummy $ pure DailyActDummyData
|
||||
-- -- ]
|
||||
-- -- in renderAForm FormStandard
|
||||
-- -- $ (, mempty) . First . Just
|
||||
-- -- <$> multiActionA acts (fslI MsgTableAction) Nothing
|
||||
-- , dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
-- , dbParamsFormResult = _1
|
||||
-- , dbParamsFormIdent = def
|
||||
-- }
|
||||
-- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
|
||||
-- -> FormResult ( DailyTableActionData, Set TutorialId)
|
||||
-- postprocess inp = do
|
||||
-- (First (Just act), jobMap) <- inp
|
||||
-- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
-- return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
|
||||
-- over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
over _2 Just <$> dbTable psValidator DBTable{..}
|
||||
|
||||
|
||||
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
|
||||
getSchoolDayR = postSchoolDayR
|
||||
postSchoolDayR ssh nd = do
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
dday <- formatTime SelFormatDate nd
|
||||
let unFormResult = getDBFormResult $ \row -> let tpt = row ^. resultParticipant . _entityVal
|
||||
in DailyFormData
|
||||
{ dailyFormDrivingPermit = tpt ^. _tutorialParticipantDrivingPermit
|
||||
, dailyFormEyeExam = tpt ^. _tutorialParticipantEyeExam
|
||||
, dailyFormParticipantNote = tpt ^. _tutorialParticipantNote
|
||||
, dailyFormAttendance = row ^? resultParticipantDay ._tutorialParticipantDayAttendance & fromMaybe False
|
||||
, dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just
|
||||
, dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False
|
||||
}
|
||||
dcrs <- memcachedByGet (CacheKeyTutorialCheckResults ssh nd)
|
||||
(fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd dcrs
|
||||
-- logInfoS "****DailyTable****" $ tshow tableRes
|
||||
formResult tableRes $ \resMap -> do
|
||||
tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do
|
||||
-- logDebugS "TableForm" (tshow dfd)
|
||||
TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated
|
||||
when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit
|
||||
|| tutorialParticipantEyeExam /= dailyFormEyeExam
|
||||
|| tutorialParticipantNote /= dailyFormParticipantNote) $
|
||||
update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit
|
||||
, TutorialParticipantEyeExam =. dailyFormEyeExam
|
||||
, TutorialParticipantNote =. dailyFormParticipantNote
|
||||
]
|
||||
let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd
|
||||
if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote)
|
||||
then deleteBy tpdUq
|
||||
else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote)
|
||||
[ TutorialParticipantDayAttendance =. dailyFormAttendance
|
||||
, TutorialParticipantDayNote =. dailyFormAttendanceNote
|
||||
]
|
||||
let udUq = UniqueUserDay tutorialParticipantUser nd
|
||||
updateUserDay = if dailyFormParkingToken
|
||||
then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued
|
||||
else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False
|
||||
updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken]
|
||||
return tutorialParticipantTutorial
|
||||
forM_ tuts $ \tid -> do
|
||||
memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text)
|
||||
memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text)
|
||||
-- audit log? Currently decided against.
|
||||
memcachedByInvalidate (CacheKeyTutorialCheckResults ssh nd) $ Proxy @DayCheckResults
|
||||
addMessageI Success $ MsgTutorialParticipantsDayEdits dday
|
||||
redirect $ SchoolR ssh $ SchoolDayR nd
|
||||
|
||||
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
|
||||
let consistencyBtn = btnModal MsgMenuSchoolDayCheck [BCIsButton, BCDefault] (Left $ SomeRoute $ SchoolR ssh $ SchoolDayCheckR nd)
|
||||
setTitleI (MsgMenuSchoolDay ssh dday)
|
||||
$(i18nWidgetFile "day-view")
|
||||
|
||||
|
||||
-- | A wrapper for several check results on tutorial participants
|
||||
data DayCheckResult = DayCheckResult
|
||||
{ dcAvsKnown :: Bool
|
||||
, dcApronAccess :: Bool
|
||||
, dcBookingFirmOk :: Bool
|
||||
, dcEyeFitsPermit :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Show, Generic, Binary)
|
||||
|
||||
data DayCheckResults = DayCheckResults
|
||||
{ dcrTimestamp :: UTCTime
|
||||
, dcrResults :: Map TutorialParticipantId DayCheckResult
|
||||
}
|
||||
deriving (Show, Generic, Binary)
|
||||
|
||||
-- | True iff there is no problem at all
|
||||
dcrIsOk :: DayCheckResult -> Bool
|
||||
dcrIsOk (DayCheckResult True True True (Just True)) = True
|
||||
dcrIsOk _ = False
|
||||
|
||||
-- | defines categories on DayCheckResult, implying an ordering, with most severe being least
|
||||
dcrSeverity :: DayCheckResult -> Int
|
||||
dcrSeverity DayCheckResult{dcAvsKnown = False } = 1
|
||||
dcrSeverity DayCheckResult{dcApronAccess = False } = 2
|
||||
dcrSeverity DayCheckResult{dcBookingFirmOk = False } = 3
|
||||
dcrSeverity DayCheckResult{dcEyeFitsPermit = Nothing } = 4
|
||||
dcrSeverity DayCheckResult{dcEyeFitsPermit = Just False} = 5
|
||||
dcrSeverity _ = 99
|
||||
|
||||
instance Ord DayCheckResult where
|
||||
compare = compare `on` dcrSeverity
|
||||
|
||||
type DayCheckGroups = ( Set TutorialParticipantId -- 1 severity
|
||||
, Set TutorialParticipantId -- 2
|
||||
, Set TutorialParticipantId -- 3
|
||||
, Set TutorialParticipantId -- 4
|
||||
, Set TutorialParticipantId -- 5
|
||||
)
|
||||
|
||||
dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> DayCheckGroups
|
||||
dcrSeverityGroups = Map.foldMapWithKey groupBySeverity
|
||||
where
|
||||
groupBySeverity :: TutorialParticipantId -> DayCheckResult -> DayCheckGroups
|
||||
groupBySeverity tpid dcr =
|
||||
let sempty = mempty :: DayCheckGroups
|
||||
in case dcrSeverity dcr of
|
||||
1 -> set _1 (Set.singleton tpid) sempty
|
||||
2 -> set _2 (Set.singleton tpid) sempty
|
||||
3 -> set _3 (Set.singleton tpid) sempty
|
||||
4 -> set _4 (Set.singleton tpid) sempty
|
||||
5 -> set _5 (Set.singleton tpid) sempty
|
||||
_ -> sempty
|
||||
|
||||
-- | Possible outcomes for DayCheckResult
|
||||
dcrMessages :: [SomeMessage UniWorX]
|
||||
dcrMessages = [ SomeMessage MsgAvsPersonSearchEmpty
|
||||
, SomeMessage MsgAvsNoApronCard
|
||||
, SomeMessage $ MsgAvsNoCompanyCard Nothing
|
||||
, SomeMessage MsgCheckEyePermitMissing
|
||||
, SomeMessage MsgCheckEyePermitIncompatible
|
||||
]
|
||||
|
||||
-- | Show most important problem as text
|
||||
dcr2widgetTxt :: Maybe CompanyName -> DayCheckResult -> Widget
|
||||
dcr2widgetTxt _ DayCheckResult{dcAvsKnown=False} = i18n MsgAvsPersonSearchEmpty
|
||||
dcr2widgetTxt _ DayCheckResult{dcApronAccess=False} = i18n MsgAvsNoApronCard
|
||||
dcr2widgetTxt mcn DayCheckResult{dcBookingFirmOk=False} = i18n $ MsgAvsNoCompanyCard mcn
|
||||
dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Nothing} = i18n MsgCheckEyePermitMissing
|
||||
dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Just False}= i18n MsgCheckEyePermitIncompatible
|
||||
dcr2widgetTxt _ _ = i18n MsgNoProblem
|
||||
|
||||
-- | Show all problems as icon with tooltip
|
||||
dcr2widgetIcn :: Maybe CompanyName -> DayCheckResult -> Widget
|
||||
dcr2widgetIcn mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk]
|
||||
where
|
||||
mkTooltip ico msg = iconTooltip msg (Just ico) True
|
||||
|
||||
avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (i18n MsgAvsPersonSearchEmpty)
|
||||
apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (i18n MsgAvsNoApronCard)
|
||||
bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning (i18n $ MsgAvsNoCompanyCard mcn)
|
||||
permitChk | isNothing dcEyeFitsPermit = mkTooltip IconFileMissing (i18n MsgCheckEyePermitMissing)
|
||||
| dcEyeFitsPermit == Just False = mkTooltip IconGlasses (i18n MsgCheckEyePermitIncompatible)
|
||||
| otherwise = mempty
|
||||
|
||||
type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName)
|
||||
|
||||
dayCheckParticipant :: Map AvsPersonId AvsDataPerson
|
||||
-> ParticipantCheckData
|
||||
-> DayCheckResult
|
||||
dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, _udn, _usn, mapi, mcmp) =
|
||||
let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit
|
||||
(dcAvsKnown, (dcApronAccess, dcBookingFirmOk))
|
||||
| Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi
|
||||
= (True , mapBoth getAny $ foldMap (hasApronAccess &&& fitsBooking mcmp) apcs)
|
||||
| otherwise
|
||||
= (False, (False, False))
|
||||
in DayCheckResult{..}
|
||||
where
|
||||
hasApronAccess :: AvsDataPersonCard -> Any
|
||||
hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorGelb} = Any True
|
||||
hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorRot} = Any True
|
||||
hasApronAccess _ = Any False
|
||||
|
||||
fitsBooking :: Maybe CompanyName -> AvsDataPersonCard -> Any
|
||||
fitsBooking (Just cn) AvsDataPersonCard{avsDataValid=True,avsDataFirm=Just df} = Any $ cn == stripCI df
|
||||
fitsBooking _ _ = Any False
|
||||
|
||||
-- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
|
||||
getSchoolDayCheckR :: SchoolId -> Day -> Handler Html
|
||||
getSchoolDayCheckR ssh nd = do
|
||||
-- isAdmin <- hasReadAccessTo AdminR
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
dday <- formatTime SelFormatDate nd
|
||||
|
||||
(tuts, parts_avs, examProblemsTbl) <- runDB $ do
|
||||
tuts <- getDayTutorials ssh (nd,nd)
|
||||
parts_avs :: [ParticipantCheckData] <- $(unValueNIs 5 [2..5]) <<$>> E.select (do
|
||||
(tpa :& usr :& avs :& cmp) <- E.from $ E.table @TutorialParticipant
|
||||
`E.innerJoin` E.table @User
|
||||
`E.on` (\(tpa :& usr) -> tpa E.^. TutorialParticipantUser E.==. usr E.^. UserId)
|
||||
`E.leftJoin` E.table @UserAvs
|
||||
`E.on` (\(tpa :& _ :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser)
|
||||
`E.leftJoin` E.table @Company
|
||||
`E.on` (\(tpa :& _ :& _ :& cmp) -> tpa E.^. TutorialParticipantCompany E.==. cmp E.?. CompanyId)
|
||||
E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals (Map.keys tuts)
|
||||
-- E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName] -- order no longer needed
|
||||
return (tpa, usr E.^. UserDisplayName, usr E.^. UserSurname, avs E.?. UserAvsPersonId, cmp E.?. CompanyName)
|
||||
)
|
||||
-- additionally queue proper AVS synchs for all users, unless there were already done today
|
||||
void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday)
|
||||
-- check for double examiners
|
||||
examProblemsTbl <- mkExamProblemsTable ssh nd
|
||||
return (tuts, parts_avs, examProblemsTbl)
|
||||
let getApi :: ParticipantCheckData -> Set AvsPersonId
|
||||
getApi = foldMap Set.singleton . view _4
|
||||
avsStats :: Map AvsPersonId AvsDataPerson <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update)
|
||||
-- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
|
||||
let toPartMap :: ParticipantCheckData -> Map TutorialParticipantId DayCheckResult
|
||||
toPartMap pcd = Map.singleton (pcd ^. _1 . _entityKey) $ dayCheckParticipant avsStats pcd
|
||||
participantResults = foldMap toPartMap parts_avs
|
||||
memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now participantResults
|
||||
|
||||
-- the following is only for displaying results neatly
|
||||
let sortBadParticipant acc pcd =
|
||||
let tid = pcd ^. _1 . _entityVal . _tutorialParticipantTutorial
|
||||
pid = pcd ^. _1 . _entityKey
|
||||
udn = pcd ^. _2
|
||||
ok = maybe False dcrIsOk $ Map.lookup pid participantResults
|
||||
in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc
|
||||
badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) -- UserDisplayName as Key ensures proper sort order
|
||||
badTutPartMap = foldl' sortBadParticipant mempty parts_avs
|
||||
|
||||
mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget
|
||||
mkBaddieWgt pid pcd =
|
||||
let name = nameWidget (pcd ^. _2) (pcd ^. _3)
|
||||
bookFirm = pcd ^. _5
|
||||
problemText = maybe (text2widget "???") (dcr2widgetTxt bookFirm) (Map.lookup pid participantResults)
|
||||
problemIcons = maybe mempty (dcr2widgetIcn bookFirm) (Map.lookup pid participantResults)
|
||||
in [whamlet|^{name}: ^{problemIcons} ^{problemText}|]
|
||||
|
||||
siteLayoutMsg MsgMenuSchoolDayCheck $ do
|
||||
setTitleI MsgMenuSchoolDayCheck
|
||||
[whamlet|
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgMenuSchoolDay ssh dday}
|
||||
<p>
|
||||
$if Map.null badTutPartMap
|
||||
_{MsgNoProblem}.
|
||||
$else
|
||||
<dl .deflist.profile-dl>
|
||||
$forall (tid,badis) <- Map.toList badTutPartMap
|
||||
<dt .deflist__dt>
|
||||
#{maybe "???" fst (Map.lookup tid tuts)}
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
$forall ((_udn,pid),pcd) <- Map.toList badis
|
||||
<li>
|
||||
^{mkBaddieWgt pid pcd}
|
||||
<section>
|
||||
<p>
|
||||
<h4 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
||||
_{MsgPossibleCheckResults}
|
||||
<p>
|
||||
<ul>
|
||||
$forall msg <- dcrMessages
|
||||
<li>_{msg}
|
||||
<p>
|
||||
_{MsgAvsUpdateDayCheck}
|
||||
<section>
|
||||
^{maybeTable' MsgExamProblemReoccurrence (Just MsgExamNoProblemReoccurrence) Nothing examProblemsTbl}
|
||||
<section>
|
||||
^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
|
||||
|]
|
||||
|
||||
|
||||
type TblExamPrbsExpr = ( E.SqlExpr (Entity Course)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Exam)
|
||||
`E.InnerJoin` E.SqlExpr (Entity ExamRegistration)
|
||||
`E.InnerJoin` E.SqlExpr (Entity ExamOccurrence)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
type TblExamPrbsData = DBRow (Entity Course, Entity Exam, Entity ExamRegistration, Entity ExamOccurrence, Entity User, Entity User)
|
||||
|
||||
-- | Table listing double examiner problems for a given school and day
|
||||
mkExamProblemsTable :: SchoolId -> Day -> DB (Bool, Widget)
|
||||
mkExamProblemsTable =
|
||||
let dbtIdent = "exams-user" :: Text
|
||||
dbtStyle = def
|
||||
dbtSQLQuery' exOccs (crs `E.InnerJoin` exm `E.InnerJoin` reg `E.InnerJoin` occ `E.InnerJoin` usr `E.InnerJoin` xmr) = do
|
||||
EL.on $ xmr E.^. UserId E.=?. occ E.^. ExamOccurrenceExaminer
|
||||
EL.on $ usr E.^. UserId E.==. reg E.^. ExamRegistrationUser
|
||||
EL.on $ occ E.^. ExamOccurrenceId E.=?. reg E.^. ExamRegistrationOccurrence
|
||||
EL.on $ exm E.^. ExamId E.==. reg E.^. ExamRegistrationExam
|
||||
EL.on $ exm E.^. ExamCourse E.==. crs E.^. CourseId
|
||||
E.where_ $ occ E.^. ExamOccurrenceId `E.in_` E.vals exOccs
|
||||
E.&&. E.exists (do
|
||||
altReg :& altOcc <- E.from $ E.table @ExamRegistration `E.innerJoin` E.table @ExamOccurrence
|
||||
`E.on` (\(altReg :& altOcc) -> altReg E.^. ExamRegistrationOccurrence E.?=. altOcc E.^. ExamOccurrenceId)
|
||||
E.where_ $ altReg E.^. ExamRegistrationUser E.==. reg E.^. ExamRegistrationUser
|
||||
E.&&. altReg E.^. ExamRegistrationId E.!=. reg E.^. ExamRegistrationId
|
||||
E.&&. altOcc E.^. ExamOccurrenceExaminer E.==. occ E.^. ExamOccurrenceExaminer
|
||||
E.&&. altOcc E.^. ExamOccurrenceId E.!=. occ E.^. ExamOccurrenceId
|
||||
)
|
||||
return (crs,exm,reg,occ,usr,xmr)
|
||||
queryExmCourse :: TblExamPrbsExpr -> E.SqlExpr (Entity Course)
|
||||
queryExmCourse = $(sqlIJproj 6 1)
|
||||
queryExam :: TblExamPrbsExpr -> E.SqlExpr (Entity Exam)
|
||||
queryExam = $(sqlIJproj 6 2)
|
||||
queryRegistration :: TblExamPrbsExpr -> E.SqlExpr (Entity ExamRegistration)
|
||||
queryRegistration = $(sqlIJproj 6 3)
|
||||
queryOccurrence :: TblExamPrbsExpr -> E.SqlExpr (Entity ExamOccurrence)
|
||||
queryOccurrence = $(sqlIJproj 6 4)
|
||||
queryTestee :: TblExamPrbsExpr -> E.SqlExpr (Entity User)
|
||||
queryTestee = $(sqlIJproj 6 5)
|
||||
queryExaminer :: TblExamPrbsExpr -> E.SqlExpr (Entity User)
|
||||
queryExaminer = $(sqlIJproj 6 6)
|
||||
resultExmCourse :: Lens' TblExamPrbsData (Entity Course)
|
||||
resultExmCourse = _dbrOutput . _1
|
||||
resultExam :: Lens' TblExamPrbsData (Entity Exam)
|
||||
resultExam = _dbrOutput . _2
|
||||
resultRegistration :: Lens' TblExamPrbsData (Entity ExamRegistration)
|
||||
resultRegistration = _dbrOutput . _3
|
||||
resultOccurrence :: Lens' TblExamPrbsData (Entity ExamOccurrence)
|
||||
resultOccurrence = _dbrOutput . _4
|
||||
resultTestee :: Lens' TblExamPrbsData (Entity User)
|
||||
resultTestee = _dbrOutput . _5
|
||||
resultExaminer :: Lens' TblExamPrbsData (Entity User)
|
||||
resultExaminer = _dbrOutput . _6
|
||||
dbtRowKey = queryRegistration >>> (E.^. ExamRegistrationId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "course") (i18nCell MsgTableCourse) $ fmap addIndicatorCell courseCell <$> view (resultExmCourse . _entityVal)
|
||||
, sortable (Just "exam") (i18nCell MsgCourseExam) $ \row -> examCell (row ^. resultExmCourse . _entityVal) (row ^. resultExam . _entityVal)
|
||||
, sortable (Just "registration")(i18nCell MsgCourseExamRegistrationTime)$ dateCell . view (resultRegistration . _entityVal . _examRegistrationTime)
|
||||
, sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ examOccurrenceCell . view resultOccurrence
|
||||
, sortable (Just "testee") (i18nCell MsgExamParticipant) $ cellHasUserLink ForProfileDataR . view resultTestee
|
||||
, sortable (Just "examiner") (i18nCell MsgExamCorrectors) $ cellHasUser . view resultExaminer
|
||||
]
|
||||
validator = def & defaultSorting [SortAscBy "course", SortAscBy "exam", SortAscBy "testee"] -- [SortDescBy "registration"]
|
||||
dbtSorting = Map.fromList
|
||||
[ ( "course" , SortColumn $ queryExmCourse >>> (E.^. CourseName))
|
||||
, ( "exam" , SortColumn $ queryExam >>> (E.^. ExamName))
|
||||
, ( "registration", SortColumn $ queryRegistration >>> (E.^. ExamRegistrationTime))
|
||||
, ( "occurrence" , SortColumn $ queryOccurrence >>> (E.^. ExamOccurrenceName))
|
||||
, ( "testee" , SortColumn $ queryTestee >>> (E.^. UserDisplayName))
|
||||
, ( "examiner" , SortColumn $ queryExaminer >>> (E.^. UserDisplayName))
|
||||
]
|
||||
dbtFilter = mempty
|
||||
dbtFilterUI = mempty
|
||||
dbtParams = def
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
in \ssh nd -> do
|
||||
exOccs <- getDayExamOccurrences False ssh Nothing (nd,nd)
|
||||
let dbtSQLQuery = dbtSQLQuery' $ Map.keys exOccs
|
||||
(_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
||||
|
||||
@ -1,375 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications, BlockArguments #-}
|
||||
|
||||
|
||||
module Handler.Tutorial.Users
|
||||
( getTUsersR, postTUsersR
|
||||
, getTExamR, postTExamR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Control.Monad.Zip (munzip)
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Print
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Course.Cache
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences, copyExamOccurrences)
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
-- import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
-- import qualified Data.Time.Zones as TZ
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Course.Users
|
||||
|
||||
|
||||
data TutorialUserAction
|
||||
= TutorialUserAssignExam
|
||||
| TutorialUserPrintQualification
|
||||
| TutorialUserRenewQualification
|
||||
| TutorialUserGrantQualification
|
||||
| TutorialUserSendMail
|
||||
| TutorialUserDeregister
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe TutorialUserAction
|
||||
instance Finite TutorialUserAction
|
||||
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
||||
|
||||
data TutorialUserActionData
|
||||
= TutorialUserPrintQualificationData
|
||||
| TutorialUserRenewQualificationData
|
||||
{ tuQualification :: QualificationId }
|
||||
| TutorialUserGrantQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
, tuValidUntil :: Maybe Day
|
||||
}
|
||||
| TutorialUserSendMailData
|
||||
| TutorialUserDeregisterData
|
||||
| TutorialUserAssignExamData
|
||||
{ tuOccurrenceId :: ExamOccurrenceId
|
||||
, tuExaminerAgain :: Bool
|
||||
, tuReassign :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
-- non-table form for general tutorial actions
|
||||
data GenTutAction
|
||||
= GenTutActShowExam
|
||||
| GenTutActOccCopyWeek
|
||||
| GenTutActOccCopyLast
|
||||
| GenTutActOccEdit
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''GenTutAction id
|
||||
|
||||
data GenTutActionData = GenTutActionData { gtaAct :: GenTutAction, gtaExam :: ExamId }
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
-- mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
|
||||
-- mkGenTutForm fltr = renderAForm FormStandard maa
|
||||
-- where
|
||||
-- maa = multiActionA acts (fslI MsgCourseExam) Nothing
|
||||
|
||||
-- acts :: Map GenTutAction (AForm Handler GenTutActionData)
|
||||
-- acts = Map.fromList
|
||||
-- [ (GenTutActOccCopy, GenTutActOccCopyData <$> areq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
|
||||
-- , (GenTutActOccEdit, GenTutActOccEditData <$> aopt (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
|
||||
-- ]
|
||||
mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
|
||||
mkGenTutForm fltr html = do
|
||||
(actRes, actView) <- mreq (selectFieldList ((\a->(a,a)) <$> universeF)) (fslI MsgCourseExam) Nothing
|
||||
(exmRes, exmView) <- mreq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing
|
||||
let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData
|
||||
res (FormSuccess gta) (FormSuccess eid) = FormSuccess $ GenTutActionData{gtaAct=gta, gtaExam=eid}
|
||||
res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2
|
||||
res (FormFailure e) _ = FormFailure e
|
||||
res _ (FormFailure e) = FormFailure e
|
||||
res _ _ = FormMissing
|
||||
viw = [whamlet|
|
||||
<p>
|
||||
#{html}^{fvInput actView} _{MsgFor} ^{fvInput exmView}
|
||||
|]
|
||||
return (res actRes exmRes, viw)
|
||||
|
||||
|
||||
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
|
||||
getTUsersR = postTUsersR
|
||||
postTUsersR tid ssh csh tutn = do
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original tutn
|
||||
croute = CTutorialR tid ssh csh tutn TUsersR
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
(Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, dbegin, hasExams, exmFltr, exOccs) <- runDB do
|
||||
trm <- get404 tid
|
||||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
(cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn
|
||||
qualifications <- getCourseQualifications cid
|
||||
let dayExpiry = case nubOrd (mapMaybe (view _qualificationValidDuration) qualifications) of
|
||||
[oneDuration] -> Just $ Just $ computeNewValidDate oneDuration nowaday -- suggest end day only if it is unique for all course qualifications
|
||||
_ -> Nothing -- using the minimum here causes confusion, better leave blank!
|
||||
colChoices = mconcat $
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
||||
, colUserEmail
|
||||
, colUserMatriclenr isAdmin
|
||||
] <>
|
||||
[ colUserQualificationBlocked isAdmin nowaday q | q <- qualifications] <>
|
||||
[ colUserExamOccurrencesCheck tid ssh csh
|
||||
, colUserExams tid ssh csh
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
|
||||
isInTut q = E.exists do
|
||||
tutorialParticipant <- E.from $ E.table @TutorialParticipant
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
|
||||
qualOptions = qualificationsOptionList qualifications
|
||||
lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
|
||||
timespan = lessonTimesSpan lessons
|
||||
(dbegin, dend) = munzip timespan
|
||||
tbegin = toMidnight . succ <$> dbegin
|
||||
tend = toMidnight <$> dend
|
||||
exmFltr = ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing]) ++ [ExamCourse ==. cid, ExamStart <=. tend]
|
||||
-- $logInfoS "ExamOccurrenceForm" [st|Exams from #{tshow tbegin} until #{tshow tend}.|]
|
||||
exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid -- :: ExamOccurrenceMap
|
||||
hasExams <- if null exOccs then exists exmFltr else pure True
|
||||
let
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList $
|
||||
bcons (not $ null exOccs)
|
||||
( TutorialUserAssignExam
|
||||
, TutorialUserAssignExamData
|
||||
<$> apopt (selectField $ pure $ mkExamOccurrenceOptions exOccs) (fslI MsgCourseUserExamOccurrences) Nothing
|
||||
<*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceAgainExaminer) (Just False)
|
||||
<*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceOverride) (Just False)
|
||||
) $
|
||||
(if null qualifications then mempty else
|
||||
[ ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
||||
<*> aopt dayField (fslI MsgLmsQualificationValidUntil & setTooltip MsgTutorialUserGrantQualificationDateTooltip) dayExpiry
|
||||
)
|
||||
]
|
||||
) ++
|
||||
[ ( TutorialUserSendMail , pure TutorialUserSendMailData )
|
||||
, ( TutorialUserDeregister , pure TutorialUserDeregisterData )
|
||||
, ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData )
|
||||
]
|
||||
table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
|
||||
return (tutEnt, table, qualifications, dbegin, hasExams, exmFltr, exOccs)
|
||||
|
||||
let courseQids = entities2map qualifications
|
||||
tcontent <- formResultMaybe participantRes $ \case
|
||||
(TutorialUserPrintQualificationData, selectedUsers) -> do
|
||||
rcvr <- requireAuth
|
||||
encRcvr <- encrypt $ entityKey rcvr
|
||||
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
|
||||
let mbAletter = anyone letters
|
||||
case mbAletter of
|
||||
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen
|
||||
Just aletter -> do
|
||||
apcIdent <- letterApcIdent aletter encRcvr now
|
||||
let fName = letterFileName aletter
|
||||
renderLetters rcvr letters apcIdent >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
|
||||
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
|
||||
-- let typePDF :: ContentType
|
||||
-- typePDF = "application/pdf"
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||
| Just grantQual <- Map.lookup tuQualification courseQids ->
|
||||
case tuValidUntil <|> (flip computeNewValidDate nowaday <$> qualificationValidDuration grantQual) of
|
||||
Nothing -> do -- TODO: change QualificationUser to have an optionnal validUntil for idefinitely valid qualifications
|
||||
addMessageI Error $ MsgTutorialUserGrantQualificationDateError $ qualificationShorthand grantQual
|
||||
return Nothing
|
||||
(Just expiryDay) -> do
|
||||
let qsh = qualificationShorthand grantQual
|
||||
reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
|
||||
selUsrs = Set.toList selectedUsers
|
||||
expiryDayText <- formatTime SelFormatDate expiryDay
|
||||
nterm <- runDB $ do
|
||||
forM_ selUsrs $ upsertQualificationUser tuQualification now expiryDay Nothing reason
|
||||
terminateLms (LmsOrphanReasonManualGrant [st|bis #{expiryDayText}, #{reason}|]) tuQualification selUsrs
|
||||
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh expiryDayText $ Set.size selectedUsers
|
||||
when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
|
||||
reloadKeepGetParams croute
|
||||
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
||||
| Just grantQual <- Map.lookup tuQualification courseQids -> do
|
||||
let qsh = qualificationShorthand grantQual
|
||||
selUsrs = Set.toList selectedUsers
|
||||
mr <- getMessageRender
|
||||
(noks,nterm) <- runDB $ (,)
|
||||
<$> renewValidQualificationUsers tuQualification Nothing Nothing selUsrs
|
||||
<*> terminateLms (LmsOrphanReasonManualGrant $ mr heading) tuQualification selUsrs
|
||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks
|
||||
when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
|
||||
reloadKeepGetParams croute
|
||||
(TutorialUserSendMailData, selectedUsers) -> do
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
||||
(TutorialUserDeregisterData, selectedUsers) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ TutorialParticipantTutorial ==. tutid
|
||||
, TutorialParticipantUser <-. Set.toList selectedUsers
|
||||
]
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
reloadKeepGetParams croute
|
||||
(TutorialUserAssignExamData{..}, setSelectedUsers)
|
||||
| (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
|
||||
assignRes <- runDB $ do
|
||||
(Set.toList &&& Set.size -> (selectedUsers, nr_usrs)) <- if -- remove duplicate examiners, if desired
|
||||
| isJust examOccurrenceExaminer && not tuExaminerAgain -> do
|
||||
conflictingUsers <- E.select $ do
|
||||
reg :& occ <- E.from $ E.table @ExamRegistration
|
||||
`E.innerJoin` E.table @ExamOccurrence
|
||||
`E.on` (\(reg :& occ) -> occ E.^. ExamOccurrenceId E.=?. reg E.^. ExamRegistrationOccurrence)
|
||||
E.where_ $ occ E.^. ExamOccurrenceExaminer E.==. E.val examOccurrenceExaminer
|
||||
E.&&. occ E.^. ExamOccurrenceExam E.!=. E.val examOccurrenceExam
|
||||
E.&&. (reg E.^. ExamRegistrationUser `E.in_` E.vals setSelectedUsers)
|
||||
E.orderBy [E.asc $ reg E.^. ExamRegistrationUser]
|
||||
E.distinct $ pure $ reg E.^. ExamRegistrationUser
|
||||
return $ setSelectedUsers `Set.difference` Set.fromAscList (E.unValue <$> conflictingUsers)
|
||||
| otherwise -> return setSelectedUsers
|
||||
runExceptT $ do
|
||||
whenIsJust examOccurrenceCapacity $ \(fromIntegral -> totalCap) -> do
|
||||
usedCap <- lift $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. selectedUsers]
|
||||
let remCap = totalCap - usedCap
|
||||
when (nr_usrs > remCap) $ throwE $ MsgExamRoomCapacityInsufficient remCap
|
||||
let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now
|
||||
lift $ if tuReassign
|
||||
then putMany [regTemplate uid | uid <- selectedUsers] >> pure nr_usrs
|
||||
else forM selectedUsers (insertUnique . regTemplate) <&> (length . catMaybes)
|
||||
case assignRes of
|
||||
Left errm -> do
|
||||
addMessageI Error errm
|
||||
return Nothing
|
||||
Right nrOk -> do
|
||||
let total = Set.size setSelectedUsers
|
||||
allok = bool Warning Success $ nrOk == total
|
||||
addMessageI allok $ MsgTutorialUserExamAssignedFor nrOk total $ ciOriginal examOccurrenceName
|
||||
reloadKeepGetParams croute
|
||||
_other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
|
||||
|
||||
case tcontent of
|
||||
Just act -> act -- execute action and return produced content (i.e. pdf)
|
||||
Nothing -> do -- no table action content to return, continue normally
|
||||
let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR
|
||||
((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm ("FIDGeneralTutorialAction"::Text) $ mkGenTutForm exmFltr
|
||||
let gtaAnchor = "general-tutorial-action-form" :: Text
|
||||
gtaRoute = croute :#: gtaAnchor
|
||||
gtaForm = wrapForm' BtnPerform gtaWgt FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ gtaRoute
|
||||
, formEncoding = gtaEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just gtaAnchor
|
||||
}
|
||||
copyAction eId step = case dbegin of
|
||||
Nothing -> addMessageI Error MsgExamOccurrenceCopyNoStartDate
|
||||
Just dto ->
|
||||
let cfailure = addMessageI Error MsgExamOccurrenceCopyFail
|
||||
csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute
|
||||
copyFrom dfrom = copyExamOccurrences eId dfrom dto <&> (toMaybe =<< (> 0))
|
||||
step_dto = addDays (negate step) dto
|
||||
in maybeM cfailure csuccess $
|
||||
runDB $ firstJustM $ map copyFrom $ take 69 $ drop 1 [dto, step_dto..] -- search for up to 2 months / 1 year backwards
|
||||
formResult gtaRes $ \GenTutActionData{..} -> case gtaAct of
|
||||
GenTutActOccCopyWeek -> copyAction gtaExam 7
|
||||
GenTutActOccCopyLast -> copyAction gtaExam 1
|
||||
GenTutActOccEdit -> do
|
||||
Exam{examName=ename} <- runDBRead $ get404 gtaExam
|
||||
redirect $ CTutorialR tid ssh csh tutn $ TExamR ename
|
||||
GenTutActShowExam -> do
|
||||
Exam{examName=ename} <- runDBRead $ get404 gtaExam
|
||||
redirect (CExamR tid ssh csh ename EUsersR, [("exam-users-tutorial", toPathPiece tutn)])
|
||||
|
||||
tutors <- runDBRead $ E.select do
|
||||
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
||||
`E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return user
|
||||
-- $(i18nWidgetFile "exam-missing")
|
||||
html <- siteLayoutMsg heading do
|
||||
setTitleI heading
|
||||
$(widgetFile "tutorial-participants")
|
||||
return $ toTypedContent html
|
||||
|
||||
|
||||
getTExamR, postTExamR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> ExamName -> Handler Html
|
||||
getTExamR = postTExamR
|
||||
postTExamR tid ssh csh tutn exmName = do
|
||||
let baseroute = CTutorialR tid ssh csh tutn
|
||||
(Entity{entityKey=eId,entityVal=exm},exOccs) <- runDB do
|
||||
trm <- get404 tid
|
||||
(cid, tutEnt) <- fetchCourseIdTutorial tid ssh csh tutn
|
||||
exm <- getBy404 $ UniqueExam cid exmName
|
||||
let lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
|
||||
timespan = lessonTimesSpan lessons
|
||||
-- (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan
|
||||
-- exms <- selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName]
|
||||
exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid
|
||||
return (exm,exOccs)
|
||||
cueId :: CryptoUUIDExam <- encrypt eId
|
||||
let eid2eos = convertExamOccurrenceMap exOccs
|
||||
(cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
|
||||
exOcForm = (,,)
|
||||
<$> areq hiddenField "" (Just cueId)
|
||||
<*> areq (mkSetField hiddenField) "" cuEoIds
|
||||
<*> examOccurrenceMultiForm eos
|
||||
((eofRes, eofWgt), eofEnctype) <- runFormPost $ identifyForm FIDTutorialExamOccurrences $ renderAForm FormStandard exOcForm
|
||||
let eofForm = wrapForm eofWgt def{formEncoding = eofEnctype}
|
||||
formResult eofRes $ \(edCEId, edCEOIds, edOccs) -> do
|
||||
let ceoidsDelete = edCEOIds `Set.difference` setMapMaybe eofId edOccs
|
||||
$logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length edCEOIds} old occurrences, #{length ceoidsDelete} to delete, #{length $ Set.filter (isNothing . eofId) edOccs} to insert, #{length $ Set.filter (isJust . eofId) edOccs} to edit|]
|
||||
reId <- decrypt edCEId
|
||||
eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
|
||||
when (reId == eId) $ do
|
||||
(fromIntegral -> nrDel, nrUps) <- runDB $ (,)
|
||||
<$> deleteWhereCount [ExamOccurrenceExam ==. reId, ExamOccurrenceId <-. eoIdsDelete]
|
||||
<*> upsertExamOccurrences eId (Set.toList edOccs)
|
||||
let nr = nrUps + nrDel
|
||||
mstat = if nr > 0 then Success else Warning
|
||||
addMessageI mstat $ MsgExamOccurrencesEdited nrUps nrDel
|
||||
reload $ baseroute $ TExamR exmName
|
||||
|
||||
let csh_tutn = csh <> "-" <> tutn -- hack to reuse prependCourseTitle
|
||||
heading = prependCourseTitle tid ssh csh_tutn $ MsgMenuTutorialExam exmName
|
||||
siteLayoutMsg heading do
|
||||
-- setTitle $ citext2Html exmName
|
||||
setTitleI heading
|
||||
[whamlet|
|
||||
<section>
|
||||
<h2>#{CI.original exmName}
|
||||
<p>#{examDescription exm}
|
||||
<section>
|
||||
^{eofForm}
|
||||
|]
|
||||
@ -1,247 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2023-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Handler.Utils
|
||||
( module Handler.Utils
|
||||
) where
|
||||
|
||||
import Import hiding (link)
|
||||
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils.DateTime as Handler.Utils
|
||||
import Handler.Utils.Form as Handler.Utils
|
||||
import Handler.Utils.Table as Handler.Utils
|
||||
|
||||
import Handler.Utils.Zip as Handler.Utils
|
||||
import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
|
||||
-- import Handler.Utils.Submission as Handler.Utils
|
||||
import Handler.Utils.Sheet as Handler.Utils
|
||||
import Handler.Utils.Mail as Handler.Utils
|
||||
import Handler.Utils.ContentDisposition as Handler.Utils
|
||||
import Handler.Utils.I18n as Handler.Utils
|
||||
import Handler.Utils.Widgets as Handler.Utils
|
||||
import Handler.Utils.Database as Handler.Utils
|
||||
import Handler.Utils.Occurrences as Handler.Utils
|
||||
import Handler.Utils.Memcached as Handler.Utils
|
||||
import Handler.Utils.Files as Handler.Utils
|
||||
import Handler.Utils.Download as Handler.Utils
|
||||
import Handler.Utils.AuthorshipStatement as Handler.Utils
|
||||
--import Handler.Utils.Company as Handler.Utils
|
||||
import Handler.Utils.Qualification as Handler.Utils
|
||||
|
||||
import Handler.Utils.Term as Handler.Utils
|
||||
|
||||
-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed
|
||||
|
||||
import Control.Monad.Logger
|
||||
|
||||
|
||||
-- | default check if the user an active admin
|
||||
checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool
|
||||
checkAdmin = liftHandler $ hasReadAccessTo AdminR
|
||||
|
||||
-- | Prefix a message with a short course id,
|
||||
-- eg. for window title bars, etc.
|
||||
-- This function should help to make this consistent everywhere
|
||||
prependCourseTitle :: (RenderMessage master msg) =>
|
||||
TermId -> SchoolId -> CourseShorthand -> msg -> SomeMessages master
|
||||
prependCourseTitle tid ssh csh msg = JoinMsgs
|
||||
[ SomeMessage $ toPathPiece tid
|
||||
, SomeMessage dashText
|
||||
, SomeMessage $ toPathPiece ssh
|
||||
, SomeMessage dashText
|
||||
, SomeMessage csh
|
||||
, SomeMessage colonText
|
||||
, SomeMessage msg
|
||||
]
|
||||
where
|
||||
dashText :: Text
|
||||
dashText = "-"
|
||||
|
||||
colonText :: Text
|
||||
colonText = ": "
|
||||
|
||||
warnTermDays :: (RenderMessage UniWorX msg) => TermId -> Map UTCTime msg -> DB ()
|
||||
warnTermDays tid timeNames = do
|
||||
Term{..} <- get404 tid
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let alldays = Map.keysSet timeNames
|
||||
warnholidays = let hdays = Set.fromList termHolidays in
|
||||
Set.filter (\(utctDay -> d) -> Set.member d hdays) alldays
|
||||
outoftermdays = Set.filter (\(utctDay -> d) -> d < termStart || d > termEnd ) alldays
|
||||
outoflecture = Set.filter (\(utctDay -> d) -> d < termLectureStart || d > termLectureEnd) alldays
|
||||
`Set.difference` outoftermdays -- out of term implies out of lecture-time
|
||||
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid (mr (timeNames ! d)) dt
|
||||
forM_ warnholidays $ warnI MsgDayIsAHoliday
|
||||
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
||||
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
||||
|
||||
|
||||
-- | return a value only if the current user ist authorized for a given route
|
||||
guardAuthorizedFor :: ( MonadThrow m
|
||||
, MonadTrans t, MonadPlus (t (ReaderT SqlBackend m))
|
||||
, MonadAP (ReaderT SqlBackend m)
|
||||
)
|
||||
=> Route UniWorX -> a -> t (ReaderT SqlBackend m) a
|
||||
guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link
|
||||
|
||||
|
||||
runAppLoggingT :: UniWorX -> LoggingT m a -> m a
|
||||
runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
|
||||
where
|
||||
logFunc loc src lvl str = do
|
||||
f <- messageLoggerSource app <$> readTVarIO loggerTVar
|
||||
f loc src lvl str
|
||||
|
||||
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
||||
studyFeaturesWidget featId = do
|
||||
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
||||
[whamlet|
|
||||
$newline never
|
||||
_{StudyDegreeTerm degree terms}, _{MsgTableStudyFeatureAge} #{studyFeaturesSemester}
|
||||
|]
|
||||
|
||||
|
||||
getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
|
||||
|
||||
|
||||
-- | Conditional redirect that hides the URL if the user is not authorized for the route
|
||||
redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
redirectAccess url = liftHandler $ do
|
||||
-- must hide URL if not authorized
|
||||
access <- isAuthorized url False
|
||||
case access of
|
||||
Authorized -> redirect url
|
||||
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
||||
|
||||
redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
|
||||
redirectAccessWith status url = liftHandler $ do
|
||||
-- must hide URL if not authorized
|
||||
access <- isAuthorized url False
|
||||
case access of
|
||||
Authorized -> redirectWith status url
|
||||
_ -> permissionDeniedI MsgUnauthorizedRedirect
|
||||
|
||||
redirectAlternatives :: (MonadHandler m, HandlerSite m ~ UniWorX) => NonEmpty (Route (HandlerSite m)) -> m a
|
||||
redirectAlternatives = go
|
||||
where
|
||||
go (nunsnoc -> ([], r)) = redirectAccess r
|
||||
go (nunsnoc -> (r' : rs, r)) = liftHandler $ do
|
||||
access <- isAuthorized r' False
|
||||
case access of
|
||||
Authorized -> redirect r'
|
||||
_ -> redirectAlternatives (nsnoc rs r)
|
||||
|
||||
nunsnoc (x :| xs) = case nonEmpty xs of
|
||||
Nothing -> ([], x)
|
||||
Just xs' -> over _1 (x :) $ nunsnoc xs'
|
||||
nsnoc [] x = x :| []
|
||||
nsnoc (x' : xs) x = x' :| (xs ++ [x])
|
||||
|
||||
-- | redirect to currentRoute, if Just otherwise to given default
|
||||
reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
reload r = getCurrentRoute >>= redirect . fromMaybe r
|
||||
|
||||
-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known
|
||||
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
reloadKeepGetParams r = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
route <- fromMaybe r <$> getCurrentRoute
|
||||
-- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
|
||||
-- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
|
||||
redirect (route, getps)
|
||||
|
||||
-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
|
||||
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
redirectKeepGetParams route = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
redirect (route, getps)
|
||||
|
||||
previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a
|
||||
previousSuperior Nothing = mempty
|
||||
previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
|
||||
|
||||
adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
|
||||
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
|
||||
-- WARNING: this function should correspond with adminProblem2Text
|
||||
adminProblemCell AdminProblemNewCompany{}
|
||||
= i18nCell MsgAdminProblemNewCompany
|
||||
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemCompanySuperiorNotFound{..}
|
||||
= i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
= textCell $ "Problem: " <> adminProblemText
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
-- used to enable filtering, must correspond to function adminProblemCell shown above
|
||||
adminProblem2Text :: AdminProblem -> DB Text
|
||||
adminProblem2Text adprob = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case adprob of
|
||||
AdminProblemNewCompany{}
|
||||
-> return $ mr MsgAdminProblemNewCompany
|
||||
AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew}
|
||||
-> return $ mr $ SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew]
|
||||
AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
-> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid}
|
||||
-> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do
|
||||
uid <- MaybeT $ pure mbuid
|
||||
User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
|
||||
pure $ mr $ SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
-- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
|
||||
-- -> return $ mr MsgAdminProblemCompanySuperiorChange
|
||||
-- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
|
||||
-- -> get uid >>= \case
|
||||
-- Nothing ->
|
||||
-- return $ mr MsgAdminProblemCompanySuperiorChange
|
||||
-- Just User{userDisplayName = udn, userSurname = usn} ->
|
||||
-- return $ mr $ SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml}
|
||||
-> let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml
|
||||
in maybeT (return $ mr basemsg) $ do
|
||||
uid <- MaybeT $ pure mbuid
|
||||
User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
|
||||
pure $ mr $ SomeMsgs [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
-> return $ mr $ SomeMsgs [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew]
|
||||
AdminProblemUnknown{adminProblemText}
|
||||
-> return $ "Problem: " <> adminProblemText
|
||||
|
||||
-- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user
|
||||
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
|
||||
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
|
||||
SomeMsgs [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
|
||||
SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
|
||||
SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
|
||||
SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $
|
||||
SomeMsgs [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
|
||||
SomeMsgs [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
|
||||
someMessages ["Problem: ", err]
|
||||
|
||||
updateAutomatic :: Bool -> Widget
|
||||
-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
|
||||
updateAutomatic True = mempty
|
||||
updateAutomatic False = do
|
||||
msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
|
||||
messageTooltip msg
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,130 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2024-2025 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-orphans #-}
|
||||
-- Module for Template Haskell functions to be executed at compile time
|
||||
-- to allow safe static partial functions
|
||||
|
||||
module Handler.Utils.AvsUpdate where
|
||||
|
||||
|
||||
import Import
|
||||
|
||||
{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
|
||||
|
||||
-- import Utils.Avs
|
||||
|
||||
|
||||
-- FAILED ATTEMPTS AT COMPILE-TIME-CHECKS USING TEMPLATE HASKELL:
|
||||
-- import Language.Haskell.TH.Lift
|
||||
-- import Language.Haskell.TH.Syntax
|
||||
--
|
||||
-- deriving instance Lift (EntityField User typ) -- possible
|
||||
--
|
||||
-- Lift instances for lenses are not possible:
|
||||
-- type Getting r s a = (a -> Const r a) -> s -> Const r s
|
||||
-- deriving instance Lift (Getting typ AvsPersonInfo typ)
|
||||
-- deriving instance Lift (Getting (First typ) AvsPersonInfo typ)
|
||||
-- deriving instance Lift (CheckUpdate User AvsPersonInfo)
|
||||
-- instance Lift (CheckUpdate User i) where
|
||||
-- -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t
|
||||
-- liftTyped (CheckUpdate up l) = [||CheckUpdate up l||]
|
||||
-- liftTyped (CheckUpdateOpt up l) = [||CheckUpdateOpt up l||]
|
||||
--
|
||||
-- instance Lift (CheckUpdate record iraw) where
|
||||
-- -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t
|
||||
-- lift = $(makeLift ''CheckUpdate)
|
||||
-- mkUsrPerUpd upd = getUserPersonUpd $$(liftTyped upd)
|
||||
|
||||
|
||||
{-
|
||||
CheckUpdate is usually a statically known pair between a DB record and a lens.
|
||||
However, lenses cannot be an instance of Lift for compile time checking (see above).
|
||||
Hence we encode the statically known pairs through a type family.
|
||||
-}
|
||||
|
||||
|
||||
class MkCheckUpdate a where
|
||||
type MCU_Rec a :: Type
|
||||
type MCU_Raw a :: Type
|
||||
mkCheckUpdate :: a -> CheckUpdate (MCU_Rec a) (MCU_Raw a)
|
||||
|
||||
data CU_AvsPersonInfo_User
|
||||
= CU_API_UserFirstName
|
||||
| CU_API_UserSurname
|
||||
| CU_API_UserDisplayName
|
||||
| CU_API_UserBirthday
|
||||
| CU_API_UserMobile
|
||||
| CU_API_UserMatrikelnummer
|
||||
| CU_API_UserCompanyPersonalNumber
|
||||
| CU_API_UserLdapPrimaryKey
|
||||
-- CU_API_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsPersonInfo_User where
|
||||
type MCU_Rec CU_AvsPersonInfo_User = User
|
||||
type MCU_Raw CU_AvsPersonInfo_User = AvsPersonInfo
|
||||
mkCheckUpdate CU_API_UserFirstName = CheckUpdate UserFirstName _avsInfoFirstName
|
||||
mkCheckUpdate CU_API_UserSurname = CheckUpdate UserSurname _avsInfoLastName
|
||||
mkCheckUpdate CU_API_UserDisplayName = CheckUpdate UserDisplayName _avsInfoDisplayName
|
||||
mkCheckUpdate CU_API_UserBirthday = CheckUpdateMay UserBirthday _avsInfoDateOfBirth
|
||||
mkCheckUpdate CU_API_UserMobile = CheckUpdateMay UserMobile _avsInfoPersonMobilePhoneNo
|
||||
mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdateMay UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
|
||||
mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
|
||||
mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdateMay UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
-- mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
|
||||
data CU_AvsDataContact_User
|
||||
= CU_ADC_UserPostAddress
|
||||
| CU_ADC_UserDisplayEmail
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsDataContact_User where
|
||||
type MCU_Rec CU_AvsDataContact_User = User
|
||||
type MCU_Raw CU_AvsDataContact_User = AvsDataContact
|
||||
mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress
|
||||
mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
|
||||
|
||||
data CU_AvsFirmInfo_User
|
||||
= CU_AFI_UserPostAddress
|
||||
-- CU_AFI_UserEmail -- PROBLEM: UserEmail must be unique!
|
||||
-- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsFirmInfo_User where
|
||||
type MCU_Rec CU_AvsFirmInfo_User = User
|
||||
type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
|
||||
mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdateMay UserPostAddress _avsFirmPostAddress
|
||||
-- mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique!
|
||||
-- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
|
||||
|
||||
-- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
|
||||
data CU_UserAvs_User -- only used in templates/profileData.hamlet for detection
|
||||
= CU_UA_UserPinPassword
|
||||
-- CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead
|
||||
| CU_UA_UserFirstName
|
||||
| CU_UA_UserSurname
|
||||
| CU_UA_UserDisplayName
|
||||
| CU_UA_UserBirthday
|
||||
| CU_UA_UserMobile
|
||||
| CU_UA_UserMatrikelnummer
|
||||
| CU_UA_UserCompanyPersonalNumber
|
||||
| CU_UA_UserLdapPrimaryKey
|
||||
-- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmail instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_UserAvs_User where
|
||||
type MCU_Rec CU_UserAvs_User = User
|
||||
type MCU_Raw CU_UserAvs_User = UserAvs
|
||||
mkCheckUpdate CU_UA_UserPinPassword = CheckUpdateOpt UserPinPassword $ _userAvsLastCardNo . _Just . to avsFullCardNo2pin . re _Just
|
||||
-- mkCheckUpdate CU_UA_UserPostAddress = CheckUpdateOpt UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress
|
||||
mkCheckUpdate CU_UA_UserFirstName = CheckUpdateOpt UserFirstName $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName
|
||||
mkCheckUpdate CU_UA_UserSurname = CheckUpdateOpt UserSurname $ _userAvsLastPersonInfo . _Just . _avsInfoLastName
|
||||
mkCheckUpdate CU_UA_UserDisplayName = CheckUpdateOpt UserDisplayName $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName
|
||||
mkCheckUpdate CU_UA_UserBirthday = CheckUpdateOpt UserBirthday $ _userAvsLastPersonInfo . _Just . _avsInfoDateOfBirth
|
||||
mkCheckUpdate CU_UA_UserMobile = CheckUpdateOpt UserMobile $ _userAvsLastPersonInfo . _Just . _avsInfoPersonMobilePhoneNo
|
||||
mkCheckUpdate CU_UA_UserMatrikelnummer = CheckUpdateOpt UserMatrikelnummer $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
|
||||
mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
|
||||
mkCheckUpdate CU_UA_UserLdapPrimaryKey = CheckUpdateOpt UserLdapPrimaryKey $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
-- mkCheckUpdate CU_UA_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI
|
||||
@ -1,289 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2025 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE BlockArguments #-} -- do starts is own block
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Utils.Company where
|
||||
|
||||
|
||||
import Import
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Char as Char
|
||||
-- import qualified Data.Text as Text
|
||||
import Database.Persist.Postgresql
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Widgets
|
||||
|
||||
-- KeyCompany is CompanyShorthand, i.e. CI Text
|
||||
instance E.SqlString (Key Company)
|
||||
|
||||
-- Snippet to restrict to primary company only
|
||||
-- E.&&. E.notExists (do
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
-- for convenience in debugging
|
||||
instance ToText (Maybe CompanyId) where
|
||||
toText Nothing = toText ("-None-"::Text)
|
||||
toText (Just fsh) = toText $ unCompanyKey fsh
|
||||
|
||||
wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
|
||||
wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
|
||||
where
|
||||
wrapUL wgt = [whamlet|<ul .list--iconless>^{wgt}|]
|
||||
|
||||
-- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
|
||||
-- NOTE: The widget must be wrapped with <ul>
|
||||
wgtCompanies' :: Bool -> UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
|
||||
wgtCompanies' useShort uid = do
|
||||
companies <- $(E.unValueN 4) <<$>> E.select do
|
||||
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
|
||||
`E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
|
||||
let (mPri, topCmp, otherCmp) = procCmp mPri companies
|
||||
resWgt =
|
||||
[whamlet|
|
||||
$forall c <- topCmp
|
||||
<li>
|
||||
^{c}
|
||||
$forall c <- otherCmp
|
||||
<li>
|
||||
^{c}
|
||||
|]
|
||||
return $ toMaybe (notNull companies) (resWgt, companies)
|
||||
where
|
||||
procCmp _ [] = (0, [], [])
|
||||
procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
|
||||
let isTop = cmpPrio >= maxPri
|
||||
cmpWgt = companyWidget' useShort isTop (cmpSh, cmpName, cmpSpr)
|
||||
(accPri,accTop,accRem) = procCmp maxPri cs
|
||||
in ( max cmpPrio accPri
|
||||
, bool accTop (cmpWgt : accTop) isTop -- lazy evaluation after repmin example, don't factor out the bool!
|
||||
, bool (cmpWgt : accRem) accRem isTop
|
||||
)
|
||||
|
||||
type AnySuperReason = Either SupervisorReason (Maybe Text)
|
||||
|
||||
|
||||
addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
|
||||
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors reason cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> case reason of
|
||||
Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault
|
||||
Just "NULL" -> E.nothing
|
||||
other -> E.val other
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. E.justVal cid
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
]
|
||||
)
|
||||
|
||||
|
||||
-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not__ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll reason mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not__ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
] )
|
||||
|
||||
-- | removes user supervisorship on switch. WARNING: problems are only returned, but not yet written to DB via reportProblem
|
||||
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
|
||||
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
|
||||
usrRec <- get404 uid
|
||||
newCompany <- get404 newCompanyId
|
||||
mbUsrComp <- getUserPrimaryCompany uid
|
||||
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
|
||||
mbUsrAvs <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
|
||||
let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
|
||||
avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
|
||||
usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
|
||||
(UserPostAddress =. Nothing) -- use company address indirectly instead
|
||||
usrPrefPost = userPrefersPostal usrRec
|
||||
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
|
||||
(UserPrefersPostal =. companyPrefersPostal newCompany)
|
||||
usrPinPassUp = toMaybe (newCompany ^. _companyPinPassword . _not) (UserPinPassword =. Nothing)
|
||||
-- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
|
||||
usrDisplayEmail :: UserEmail = userDisplayEmail usrRec
|
||||
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
|
||||
usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
|
||||
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrPinPassUp, usrDisplayEmailUp]
|
||||
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- update uid usrUpdate
|
||||
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
|
||||
case mbUsrComp of
|
||||
Nothing -> do -- create company user
|
||||
void $ insertUnique newUserComp
|
||||
newAPs <- addDefaultSupervisors' newCompanyId $ singleton uid
|
||||
$logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} to #{unCompanyKey newCompanyId}. #{newAPs} default company supervisors upserted.|]
|
||||
return (usrUpdate, mempty)
|
||||
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
|
||||
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
|
||||
| otherwise -> do -- switch company
|
||||
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
|
||||
let newPrio = succ oldPrio
|
||||
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = newPrio}
|
||||
[UserCompanyPriority =. newPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
|
||||
-- supervised by uid
|
||||
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
|
||||
usrSup <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
|
||||
E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
|
||||
let singleSup = E.notExists $ do
|
||||
othSup <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
|
||||
E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
|
||||
E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
|
||||
return (usrSup, singleSup)
|
||||
newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
|
||||
E.delete $ do
|
||||
usrSup <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
|
||||
return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
|
||||
| (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
|
||||
-- supervisors of uid
|
||||
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef) -- default or no reason
|
||||
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr -- old company or no company
|
||||
oldAPs <- if keepOldCompanySupervs
|
||||
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
|
||||
else deleteWhereCount oldSubFltr
|
||||
nrDefSups <- addDefaultSupervisors' newCompanyId $ singleton uid -- CHECK HERE WITH LINES ABOVE
|
||||
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
|
||||
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
|
||||
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
|
||||
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
|
||||
newlyUnsupervised
|
||||
delupd = bool "deleted" "updated" keepOldCompanySupervs :: Text
|
||||
$logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} from #{unCompanyKey oldCompanyId} to #{unCompanyKey newCompanyId}. #{oldAPs} old APs #{delupd}. #{nrDefSups} default company supervisors upserted. #{newAPs} new company supervisors counted now.|]
|
||||
return (usrUpdate ,problems)
|
||||
|
||||
defaultSupervisorReasonFilter :: [Filter UserSupervisor]
|
||||
defaultSupervisorReasonFilter =
|
||||
[UserSupervisorReason ==. Nothing]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonAvsSuperior )]
|
||||
-- ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
|
||||
|
||||
-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
|
||||
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
|
||||
deleteDefaultSupervisorsForUsers cids sprs usrs =
|
||||
deleteWhereCount
|
||||
$ bcons (notNull cids) (UserSupervisorCompany <-. (cids <&> Just))
|
||||
$ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs)
|
||||
$ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
|
||||
|
||||
-- | retrieve maximum company user priority for a user
|
||||
|
||||
getCompanyUserMaxPrio :: UserId -> DB Int
|
||||
getCompanyUserMaxPrio uid = do
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
|
||||
-- | retrieve maximum company user priority for a user within SQL query
|
||||
-- Note: if there a multiple top-companies, only one is returned
|
||||
selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId))
|
||||
selectCompanyUserPrime usr = E.subSelect $ selectCompanyUserPrimeHelper $ usr E.^. UserId
|
||||
|
||||
-- | like @selectCompanyUserPrime@, but directly usable, a simpler type to think about it `UserId -> DB (Maybe CompanyId)`
|
||||
selectCompanyUserPrime' :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
|
||||
=> UserId -> ReaderT backend m (Maybe CompanyId)
|
||||
selectCompanyUserPrime' uid = fmap E.unValue <<$>> E.selectOne $ selectCompanyUserPrimeHelper $ E.val uid
|
||||
|
||||
-- selectCompanyUserPrime'' :: UserId -> DB (Maybe CompanyId)
|
||||
-- selectCompanyUserPrime'' uid = (userCompanyCompany . entityVal) <<$>> selectMaybe [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Asc UserCompanyCompany]
|
||||
|
||||
selectCompanyUserPrimeHelper :: E.SqlExpr (E.Value UserId) -> E.SqlQuery (E.SqlExpr (E.Value CompanyId))
|
||||
selectCompanyUserPrimeHelper uid = do
|
||||
uc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ uc E.^. UserCompanyUser E.==. uid
|
||||
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
||||
return (uc E.^. UserCompanyCompany)
|
||||
@ -1,188 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Handler.Utils.Course.Cache where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
-- import Handler.Utils.Occurrences
|
||||
import Handler.Exam.Form (ExamOccurrenceForm(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Aeson as Aeson
|
||||
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import Database.Esqueleto.PostgreSQL.JSON ((@>.))
|
||||
-- import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
|
||||
|
||||
|
||||
|
||||
-- partial JSON object to be used for filtering with "@>"
|
||||
-- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions
|
||||
-- occurrenceDayValue :: Day -> Value
|
||||
-- occurrenceDayValue d = Aeson.object
|
||||
-- [ "exceptions" Aeson..=
|
||||
-- [ Aeson.object
|
||||
-- [ "exception" Aeson..= ("occur"::Text)
|
||||
-- , "day" Aeson..= d
|
||||
-- ] ] ]
|
||||
|
||||
{- More efficient DB-only version, but ignores regular schedules
|
||||
getDayTutorials :: SchoolId -> Day -> DB [TutorialId]
|
||||
getDayTutorials ssh d = E.unValue <<$>> E.select (do
|
||||
(trm :& crs :& tut) <- E.from $ E.table @Term
|
||||
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
||||
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
|
||||
E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd)
|
||||
E.&&. crs E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d))
|
||||
return $ tut E.^. TutorialId
|
||||
)
|
||||
-}
|
||||
|
||||
-- | Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable
|
||||
data CourseCacheKeys
|
||||
= CacheKeyTutorialOccurrences SchoolId (Day,Day) -- ^ Map TutorialId (TutorialName, [LessonTime])
|
||||
| CacheKeyExamOccurrences SchoolId (Day,Day) (Maybe CourseId) -- ^ Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
|
||||
| CacheKeySuggsParticipantNote SchoolId TutorialId
|
||||
| CacheKeySuggsAttendanceNote SchoolId TutorialId
|
||||
| CacheKeyTutorialCheckResults SchoolId Day
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
deriving anyclass (Hashable, Binary, NFData)
|
||||
|
||||
-- getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
|
||||
-- getDayTutorials ssh dlimit@(dstart, dend )
|
||||
-- | dstart > dend = return mempty
|
||||
-- | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do -- same key is ok, distinguished by return type
|
||||
-- candidates <- E.select $ do
|
||||
-- (trm :& crs :& tut) <- E.from $ E.table @Term
|
||||
-- `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
||||
-- `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
|
||||
-- E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
|
||||
-- E.&&. trm E.^. TermStart E.<=. E.val dend
|
||||
-- E.&&. trm E.^. TermEnd E.>=. E.val dstart
|
||||
-- return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart))
|
||||
-- -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
|
||||
-- return $ mapMaybe checkCandidate candidates
|
||||
-- where
|
||||
-- period = Set.fromAscList [dstart..dend]
|
||||
|
||||
-- checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case
|
||||
-- checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _)
|
||||
-- | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ
|
||||
-- = Just tutId
|
||||
-- | otherwise
|
||||
-- = Nothing
|
||||
|
||||
-- | like the previous version above, but also returns the lessons occurring within the given time frame
|
||||
-- Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise
|
||||
getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime]))
|
||||
getDayTutorials ssh dlimit@(dstart, dend )
|
||||
| dstart > dend = return mempty
|
||||
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do
|
||||
candidates <- E.select $ do
|
||||
(trm :& crs :& tut) <- E.from $ E.table @Term
|
||||
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
||||
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
|
||||
E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. trm E.^. TermStart E.<=. E.val dend
|
||||
E.&&. trm E.^. TermEnd E.>=. E.val dstart
|
||||
return (trm, tut)
|
||||
-- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
|
||||
return $ foldMap checkCandidate candidates
|
||||
where
|
||||
checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId (TutorialName, [LessonTime])
|
||||
checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}})
|
||||
| let lessons = Set.filter lessonFltr $ occurringLessons trm occ
|
||||
, notNull lessons
|
||||
= Map.singleton tutId (tName , Set.toAscList lessons) -- due to Set not having a Functor instance, we need mostly need lists anyway
|
||||
| otherwise
|
||||
= mempty
|
||||
|
||||
lessonFltr :: LessonTime -> Bool
|
||||
lessonFltr LessonTime{..} = dstart <= localDay lessonStart
|
||||
&& dend >= localDay lessonEnd
|
||||
|
||||
-- -- retrieve all exam occurrences for a school for a term in a given time period; uses caching
|
||||
-- getDayExamOccurrences :: SchoolId -> (Day,Day) -> DB (Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence))
|
||||
-- getDayExamOccurrences ssh dlimit@(dstart, dend )
|
||||
-- | dstart > dend = return mempty
|
||||
-- | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit) $ do
|
||||
-- candidates <- E.select $ do
|
||||
-- (trm :& crs :& exm :& occ) <- E.from $ E.table @Term
|
||||
-- `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
||||
-- `E.innerJoin` E.table @Exam `E.on` (\(_ :& crs :& exm) -> crs E.^. CourseId E.==. exm E.^. ExamCourse)
|
||||
-- `E.innerJoin` E.table @ExamOccurrence `E.on` (\(_ :& _ :& exm :& occ) -> exm E.^. ExamId E.==. occ E.^. ExamOccurrenceExam)
|
||||
-- E.where_ $ E.val ssh E.==. crs E.^. CourseSchool
|
||||
-- E.&&. E.val dstart E.<=. trm E.^. TermEnd
|
||||
-- E.&&. E.val dend E.>=. trm E.^. TermStart
|
||||
-- E.&&. ( E.between (E.day $ occ E.^. ExamOccurrenceStart) (E.val dstart, E.val dend)
|
||||
-- E.||. E.between (E.dayMaybe $ occ E.^. ExamOccurrenceEnd) (E.justVal dstart, E.justVal dend)
|
||||
-- )
|
||||
-- return (exm, occ)
|
||||
-- return $ foldMap mkOccMap candidates
|
||||
-- where
|
||||
-- mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
|
||||
-- mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal)
|
||||
|
||||
type ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))
|
||||
type ExamToOccurrencesMap = Map ExamId (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
|
||||
|
||||
-- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching
|
||||
-- if a CourseId is specified, only exams from that course are returned
|
||||
getDayExamOccurrences :: Bool -> SchoolId -> Maybe CourseId -> (Day,Day) -> DB ExamOccurrenceMap
|
||||
getDayExamOccurrences onlyOpen ssh mbcid dlimit@(dstart, dend)
|
||||
| dstart > dend = return mempty
|
||||
| otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit mbcid) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
candidates <- E.select $ do
|
||||
(crs :& exm :& occ) <- E.from $ E.table @Course
|
||||
`E.innerJoin` E.table @Exam `E.on` (\(crs :& exm) -> crs E.^. CourseId E.==. exm E.^. ExamCourse)
|
||||
`E.innerJoin` E.table @ExamOccurrence `E.on` (\(_ :& exm :& occ) -> exm E.^. ExamId E.==. occ E.^. ExamOccurrenceExam)
|
||||
E.where_ $ E.and $ catMaybes
|
||||
[ toMaybe onlyOpen $ E.justVal now E.>=. exm E.^. ExamRegisterFrom -- fail on null
|
||||
E.&&. E.val now E.<~. exm E.^. ExamRegisterTo -- success on null
|
||||
, mbcid <&> ((E.==. (crs E.^. CourseId)) . E.val)
|
||||
, Just $ crs E.^. CourseSchool E.==. E.val ssh
|
||||
, Just $ E.withinPeriod dlimit (occ E.^. ExamOccurrenceStart) (occ E.^. ExamOccurrenceEnd)
|
||||
]
|
||||
-- E.orderBy [E.asc $ exm E.^. ExamName] -- we return a map, so the order does not matter
|
||||
return (occ, exm E.^. ExamId, exm E.^. ExamName) -- No Binary instance for Entity Exam, so we only extract what is needed for now
|
||||
foldMapM mkOccMap candidates
|
||||
where
|
||||
mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> DB ExamOccurrenceMap
|
||||
mkOccMap (Entity{..}, E.Value eId, E.Value eName) = encrypt entityKey <&> (\ceoId -> Map.singleton entityKey (entityVal, ceoId, (eId, eName)))
|
||||
|
||||
mkExamOccurrenceOptions :: ExamOccurrenceMap -> OptionList ExamOccurrenceId
|
||||
mkExamOccurrenceOptions = mkOptionListGrouped . map (over _2 $ sortBy (compare `on` optionDisplay)) . groupSort . map mkEOOption . Map.toList
|
||||
where
|
||||
mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId])
|
||||
mkEOOption (eid, (ExamOccurrence{examOccurrenceName}, ceoId, (_,eName))) = (ciOriginal eName, [Option{..}])
|
||||
where
|
||||
optionDisplay = ciOriginal examOccurrenceName
|
||||
optionExternalValue = toPathPiece ceoId
|
||||
optionInternalValue = eid
|
||||
|
||||
convertExamOccurrenceMap :: ExamOccurrenceMap -> ExamToOccurrencesMap
|
||||
convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom
|
||||
where
|
||||
aux :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (ExamId, (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
|
||||
aux (_, (ExamOccurrence{..}, cueoId, (eid,_))) = (eid, (Set.singleton cueoId, Set.singleton ExamOccurrenceForm
|
||||
{ eofId = Just cueoId
|
||||
, eofName = Just examOccurrenceName
|
||||
, eofExaminer = examOccurrenceExaminer
|
||||
, eofRoom = examOccurrenceRoom
|
||||
, eofRoomHidden = examOccurrenceRoomHidden
|
||||
, eofCapacity = examOccurrenceCapacity
|
||||
, eofStart = examOccurrenceStart
|
||||
, eofEnd = examOccurrenceEnd
|
||||
, eofDescription = examOccurrenceDescription
|
||||
}
|
||||
))
|
||||
@ -1,196 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Handler.Utils.Occurrences
|
||||
( LessonTime(..)
|
||||
, lessonTimeWidget, lessonTimesWidget
|
||||
, lessonTimesSpan
|
||||
, occurringLessons
|
||||
, occurrencesWidget
|
||||
, occurrencesCompute, occurrencesCompute'
|
||||
, occurrencesBounds
|
||||
, occurrencesAddBusinessDays
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Utils.Holidays (isWeekend)
|
||||
import Utils.Occurrences
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Widgets (roomReferenceWidget)
|
||||
|
||||
-- import Text.Read (read) -- for DEBUGGING only
|
||||
|
||||
|
||||
----------------
|
||||
-- LessonTime --
|
||||
----------------
|
||||
--
|
||||
-- Model time intervals to compute lecture/tutorial lessons more intuitively
|
||||
--
|
||||
|
||||
data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime, lessonRoom :: Maybe RoomReference }
|
||||
deriving (Eq, Ord, Show, Generic, Binary) -- BEWARE: Ord instance might not be intuitive, but needed for Set
|
||||
|
||||
occurringLessons :: Term -> Occurrences -> Set LessonTime
|
||||
occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons
|
||||
where
|
||||
scheduledLessons = occurrenceScheduleToLessons term `foldMap` occurrencesScheduled
|
||||
(exceptOcc, exceptNo) = occurrenceExceptionToLessons occurrencesExceptions
|
||||
isExcept LessonTime{lessonStart} = Set.notMember lessonStart exceptNo
|
||||
|
||||
occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime
|
||||
occurrenceScheduleToLessons Term{..} =
|
||||
let setHolidays = Set.fromList termHolidays -- ensure that the conversion is performed only once for repeated calls
|
||||
in \ScheduleWeekly{..} ->
|
||||
let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays
|
||||
toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart
|
||||
, lessonEnd = LocalTime d scheduleEnd
|
||||
, lessonRoom = scheduleRoom
|
||||
}
|
||||
in Set.map toLesson occDays
|
||||
|
||||
occurrenceExceptionToLessons :: Set OccurrenceException -> (Set LessonTime, Set LocalTime)
|
||||
occurrenceExceptionToLessons = Set.foldr aux mempty
|
||||
where
|
||||
aux ExceptOccur{..} (oc,no) =
|
||||
let t = LessonTime { lessonStart = LocalTime exceptDay exceptStart
|
||||
, lessonEnd = LocalTime exceptDay exceptEnd
|
||||
, lessonRoom = exceptRoom
|
||||
}
|
||||
in (Set.insert t oc,no)
|
||||
aux ExceptNoOccur{..} (oc,no) =
|
||||
(oc, Set.insert exceptTime no)
|
||||
|
||||
lessonTimeWidget :: Bool -> LessonTime -> Widget
|
||||
lessonTimeWidget roomHidden LessonTime{..} = do
|
||||
lStart <- formatTime SelFormatTime lessonStart
|
||||
lEnd <- formatTime SelFormatTime lessonEnd
|
||||
$(widgetFile "widgets/lesson/single")
|
||||
|
||||
lessonTimesWidget :: (Traversable t, MonoFoldable (t Widget)) => Bool -> t LessonTime -> Widget
|
||||
lessonTimesWidget roomHidden lessonsSet = do
|
||||
let lessons = lessonTimeWidget roomHidden <$> lessonsSet
|
||||
$(widgetFile "widgets/lesson/set")
|
||||
|
||||
lessonTimesSpan :: Set LessonTime -> Maybe (Day, Day)
|
||||
lessonTimesSpan ls = comb (Set.lookupMin lDays, Set.lookupMax lDays)
|
||||
where
|
||||
lDays = Set.foldr accDay mempty ls
|
||||
accDay LessonTime{..} = Set.insert (localDay lessonStart) . Set.insert (localDay lessonEnd)
|
||||
comb (Just x, Just y) = Just (x,y)
|
||||
comb _ = Nothing
|
||||
|
||||
|
||||
-----------------
|
||||
-- Occurrences --
|
||||
-----------------
|
||||
|
||||
occurrencesWidget :: Bool -> JSONB Occurrences -> Widget
|
||||
occurrencesWidget roomHidden (normalizeOccurrences . unJSONB -> Occurrences{..}) = do
|
||||
let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
|
||||
ScheduleWeekly{..} -> do
|
||||
scheduleStart' <- formatTime SelFormatTime scheduleStart
|
||||
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
|
||||
$(widgetFile "widgets/occurrence/cell/weekly")
|
||||
occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case
|
||||
ExceptOccur{..} -> do
|
||||
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
|
||||
exceptEnd' <- formatTime SelFormatTime exceptEnd
|
||||
$(widgetFile "widgets/occurrence/cell/except-occur")
|
||||
ExceptNoOccur{..} -> do
|
||||
exceptTime' <- formatTime SelFormatDateTime exceptTime
|
||||
$(widgetFile "widgets/occurrence/cell/except-no-occur")
|
||||
$(widgetFile "widgets/occurrence/cell")
|
||||
|
||||
-- | Get all days of occurrences during a term, excluding term holidays from the regular schedule, but not from do-occur exceptions
|
||||
occurrencesCompute :: Term -> Occurrences -> Set Day
|
||||
occurrencesCompute trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ
|
||||
|
||||
-- | Less precise versison of `occurrencesCompute`, which ignores TimeOfDay; might be faster, but could be wrong in some cases
|
||||
occurrencesCompute' :: Term -> Occurrences -> Set Day
|
||||
occurrencesCompute' Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays
|
||||
where
|
||||
scdDays = Set.foldr getOccDays mempty occurrencesScheduled
|
||||
(plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions
|
||||
|
||||
getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day)
|
||||
getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc)
|
||||
getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc)
|
||||
|
||||
getOccDays :: OccurrenceSchedule -> Set Day -> Set Day
|
||||
getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday
|
||||
|
||||
-- | Get bounds for an Occurrences
|
||||
occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day)
|
||||
occurrencesBounds = (liftM2 (,) Set.lookupMin Set.lookupMax .) . occurrencesCompute
|
||||
|
||||
occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences
|
||||
occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions
|
||||
where
|
||||
newSchedule = Set.map switchDayOfWeek occurrencesScheduled
|
||||
dayDiff = diffDays dayNew dayOld
|
||||
|
||||
offDays = Set.fromList $ termHolidays <> weekends
|
||||
weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d]
|
||||
|
||||
switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule
|
||||
switchDayOfWeek os | 0 == dayDiff `mod` 7 = os
|
||||
switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)}
|
||||
|
||||
newExceptions = snd $ Set.foldl' advanceExceptions (dayDiff,mempty) occurrencesExceptions
|
||||
|
||||
-- we assume that instance Ord OccurrenceException is ordered chronologically
|
||||
advanceExceptions :: (Integer, Set OccurrenceException) -> OccurrenceException -> (Integer, Set OccurrenceException)
|
||||
advanceExceptions (offset, acc) ex
|
||||
| ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend
|
||||
, nd `Set.member` offDays
|
||||
= advanceExceptions (succ offset, acc) ex
|
||||
| otherwise
|
||||
= (offset, Set.insert (setDayOfOccurrenceException nd ex) acc)
|
||||
where
|
||||
ed = dayOfOccurrenceException ex
|
||||
nd = addDays offset ed
|
||||
|
||||
|
||||
|
||||
{-
|
||||
|
||||
-----------
|
||||
-- DEBUG --
|
||||
-----------
|
||||
theorieschulung :: Occurrences
|
||||
theorieschulung =
|
||||
Occurrences
|
||||
{occurrencesScheduled = Set.fromList
|
||||
[ScheduleWeekly {scheduleDayOfWeek = Thursday, scheduleStart = read "11:11:00", scheduleEnd = read "12:22:00"}
|
||||
,ScheduleWeekly {scheduleDayOfWeek = Friday , scheduleStart = read "13:33:00", scheduleEnd = read "14:44:00"}
|
||||
,ScheduleWeekly {scheduleDayOfWeek = Sunday , scheduleStart = read "15:55:00", scheduleEnd = read "16:06:00"}
|
||||
]
|
||||
, occurrencesExceptions = Set.fromList
|
||||
[ExceptOccur {exceptDay = read "2024-01-07", exceptStart = read "08:30:00", exceptEnd = read "16:00:00"}
|
||||
,ExceptOccur {exceptDay = read "2024-01-15", exceptStart = read "09:00:00", exceptEnd = read "16:00:00"}
|
||||
,ExceptOccur {exceptDay = read "2024-09-24", exceptStart = read "09:10:00", exceptEnd = read "16:10:00"}
|
||||
,ExceptNoOccur {exceptTime = read "2024-02-25 15:55:00"}
|
||||
,ExceptNoOccur {exceptTime = read "2024-10-25 13:33:00"}
|
||||
,ExceptNoOccur {exceptTime = read "2024-11-08 08:08:08"} -- causes difference between occurrencesCompute and occurrencesCompute'
|
||||
,ExceptNoOccur {exceptTime = read "2024-11-09 11:11:08"}
|
||||
]
|
||||
}
|
||||
|
||||
exampleTerm :: Term
|
||||
exampleTerm = Term
|
||||
{ termName = TermIdentifier {year = 2024}
|
||||
, termStart = read "2024-01-01"
|
||||
, termEnd = read "2024-12-29"
|
||||
, termHolidays = [read "2024-01-01", read "2024-03-29", read "2024-03-31", read "2024-04-01", read "2024-05-01", read "2024-05-09"
|
||||
,read "2024-05-19", read "2024-05-20", read "2024-05-30", read "2024-10-03", read "2024-12-24", read "2024-12-25", read "2024-12-26" ]
|
||||
, termLectureStart = read "2024-01-01"
|
||||
, termLectureEnd = read "2024-12-27"
|
||||
}
|
||||
|
||||
-}
|
||||
@ -1,38 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Handler.Utils.Table
|
||||
( module Handler.Utils.Table
|
||||
) where
|
||||
|
||||
import Import hiding (link)
|
||||
|
||||
import Handler.Utils.Table.Pagination as Handler.Utils.Table
|
||||
import Handler.Utils.Table.Columns as Handler.Utils.Table
|
||||
import Handler.Utils.Table.Cells as Handler.Utils.Table
|
||||
|
||||
|
||||
-- | Given a header message, a bool and widget; display widget and header only if the boolean is true
|
||||
maybeTable :: (RenderMessage UniWorX a)
|
||||
=> a -> (Bool, Widget) -> Widget
|
||||
maybeTable m = maybeTable' m Nothing Nothing
|
||||
|
||||
maybeTable' :: (RenderMessage UniWorX a)
|
||||
=> a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
|
||||
maybeTable' _ Nothing _ (False, _ ) = mempty
|
||||
maybeTable' _ (Just nodata) _ (False, _ ) =
|
||||
[whamlet|
|
||||
<div .container>
|
||||
_{nodata}
|
||||
|]
|
||||
maybeTable' hdr _ mbRemark (True ,tbl) =
|
||||
[whamlet|
|
||||
<div .container>
|
||||
<h2> _{hdr}
|
||||
<div .container>
|
||||
^{tbl}
|
||||
$maybe remark <- mbRemark
|
||||
<em>_{MsgProfileRemark}
|
||||
\ ^{remark}
|
||||
|]
|
||||
@ -1,47 +0,0 @@
|
||||
# Demo
|
||||
## Mermaid Flowcharts
|
||||
|
||||
```mermaid
|
||||
flowchart LR;
|
||||
gau([guessAvsUser])
|
||||
%% uau([XupsertAvsUser])
|
||||
uaubi[upsertAvsUserById]
|
||||
uaubis[upsertAvsUserByIds]
|
||||
uaubc[upsertAvsUserByCard]
|
||||
ldap[[ldapLookupAndUpsert]]
|
||||
lau[lookupAvsUser]
|
||||
laus[lookupAvsUsers - DEPRECATED?]
|
||||
gla[guessLicenceAddress - DEPRECATED]
|
||||
ur([?updateReceivers])
|
||||
caubi[createAvsUserById]
|
||||
ucomp[upsertAvsCompany]
|
||||
|
||||
aqc{{AvsQueryContact}}
|
||||
aqp{{AvsQueryPerson}}
|
||||
aqs{{AvsQueryStatus}}
|
||||
|
||||
|
||||
uaubc-->uaubi
|
||||
uaubc-->aqp
|
||||
|
||||
gau-->uaubi
|
||||
gau-->uaubc
|
||||
gau-->ldap
|
||||
|
||||
%% uau-..->uaubi
|
||||
%% uau-..->uaubc
|
||||
|
||||
uaubi-->uaubis
|
||||
uaubi-->caubi-->uaubis
|
||||
uaubis-->aqc
|
||||
caubi-->aqs
|
||||
caubi-->aqc
|
||||
|
||||
caubi-->ucomp
|
||||
uaubis-->ucomp
|
||||
|
||||
lau-->laus
|
||||
laus-->aqs
|
||||
|
||||
ur-->uaubi
|
||||
```
|
||||
@ -1,193 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2023 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Jobs.Handler.SynchroniseAvs
|
||||
( dispatchJobSynchroniseAvs
|
||||
-- , dispatchJobSynchroniseAvsId
|
||||
-- , dispatchJobSynchroniseAvsUser
|
||||
, dispatchJobSynchroniseAvsQueue
|
||||
, dispatchJobSynchroniseAvsLicences
|
||||
, dispatchJobSynchroniseByAvsDataContact
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
-- import qualified Data.Map as Map
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
-- import qualified Database.Esqueleto.Legacy as E hiding (upsert)
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Qualification
|
||||
|
||||
-- pause is a date in the past; don't synch again if the last synch was after pause
|
||||
dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
|
||||
dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
= JobHandlerException . runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
todos <- runConduit $ readUsers .| filterIteration now .| sinkList
|
||||
putMany todos
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch summary for #{tshow numIterations}/#{tshow epoch}/#{tshow iteration}: #{length todos}|]
|
||||
void $ queueJob JobSynchroniseAvsQueue
|
||||
where
|
||||
readUsers :: ConduitT () UserId _ ()
|
||||
readUsers = selectKeys [] []
|
||||
|
||||
filterIteration :: UTCTime -> ConduitT UserId AvsSync _ ()
|
||||
filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do
|
||||
let
|
||||
userIteration, currentIteration :: Integer
|
||||
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
|
||||
currentIteration = toInteger iteration `mod` toInteger numIterations
|
||||
$logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
|
||||
guard $ userIteration == currentIteration
|
||||
return $ AvsSync userId now pause
|
||||
|
||||
-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
|
||||
-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
|
||||
-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
|
||||
-- where
|
||||
-- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
|
||||
-- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
|
||||
|
||||
-- dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX
|
||||
-- dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause
|
||||
|
||||
-- workJobSychronizeAvs :: UserId -> Maybe Day -> Handler ()
|
||||
-- workJobSychronizeAvs uid pause = do
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- -- void $ E.upsert
|
||||
-- -- AvsSync { avsSyncUser = uid
|
||||
-- -- , avsSyncCreationTime = now
|
||||
-- -- , avsSyncPause = pause
|
||||
-- -- }
|
||||
-- -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
|
||||
-- runDB $ maybeM
|
||||
-- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
|
||||
-- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
|
||||
-- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
|
||||
-- (getBy $ UniqueAvsSyncUser uid)
|
||||
-- void $ queueJob JobSynchroniseAvsQueue
|
||||
|
||||
|
||||
-- dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
|
||||
-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
-- (unlinked,linked) <- runDB $ do
|
||||
-- jobs <- E.select (do
|
||||
-- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
|
||||
-- `E.leftJoin` E.table @UserAvs
|
||||
-- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
|
||||
-- let pause = avsSync E.^. AvsSyncPause
|
||||
-- lastSync = usrAvs E.?. UserAvsLastSynch
|
||||
-- E.where_ $ E.isNothing pause
|
||||
-- E.||. E.isNothing lastSync
|
||||
-- E.||. pause E.>. E.dayMaybe lastSync
|
||||
-- return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
|
||||
-- )
|
||||
-- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
|
||||
-- E.deleteWhere [AvsSyncId <-. syncIds]
|
||||
-- return (unlinked, linked)
|
||||
|
||||
-- void $ updateAvsUserByIds linked
|
||||
-- void $ linktoAvsUserByUIDs unlinked
|
||||
-- -- we do not reschedule failed synchs here in order to avoid a loop
|
||||
-- where
|
||||
-- discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
|
||||
-- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi)
|
||||
|
||||
dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
|
||||
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
jobs <- runDBRead $ do
|
||||
E.select (do
|
||||
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync
|
||||
`E.leftJoin` E.table @UserAvs
|
||||
`E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
|
||||
let pause = avsSync E.^. AvsSyncPause
|
||||
lastSync = usrAvs E.?. UserAvsLastSynch
|
||||
proceed = E.isNothing pause
|
||||
E.||. E.isNothing lastSync
|
||||
E.||. pause E.>. E.dayMaybe lastSync
|
||||
-- E.where_ proceed -- we still want to delete all paused jobs, rather than to delay them only
|
||||
return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId, proceed)
|
||||
)
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
|
||||
-- return jobs
|
||||
let (unlinked, linked) = foldl' discernJob mempty jobs
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
void $ updateAvsUserByIds linked
|
||||
void $ linktoAvsUserByUIDs unlinked
|
||||
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
-- we do not reschedule failed synchs here in order to avoid a loop
|
||||
where
|
||||
discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api)
|
||||
discernJob accs (E.Value uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid)
|
||||
discernJob accs ( _ , _ , E.Value False ) = accs
|
||||
|
||||
|
||||
-----------------
|
||||
-- AVS Licences
|
||||
|
||||
dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX
|
||||
-- dispatchJobSynchroniseAvsLicences = error "TODO"
|
||||
dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do
|
||||
AvsLicenceSynchConf
|
||||
{ avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
|
||||
, avsLicenceSynchReasonFilter = reasonFilter
|
||||
, avsLicenceSynchMaxChanges = maxChanges
|
||||
} <- getsYesod $ view _appAvsLicenceSynchConf
|
||||
|
||||
let procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
|
||||
procLic aLic up apids
|
||||
| n <- Set.size apids, n > 0 =
|
||||
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
|
||||
logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
|
||||
catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
|
||||
in if NTop (Just n) <= NTop maxChanges
|
||||
then do
|
||||
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
||||
when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|]
|
||||
else
|
||||
logit $ Just [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|]
|
||||
| otherwise = return ()
|
||||
|
||||
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
|
||||
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
|
||||
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
|
||||
now <- liftIO getCurrentTime
|
||||
firmBlocks <- runDBRead $ E.select $ do
|
||||
(uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
|
||||
`E.innerJoin` E.table @QualificationUser `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
|
||||
`E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) ->
|
||||
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
|
||||
E.&&. qblock `isLatestBlockBefore'` E.val now)
|
||||
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
|
||||
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
|
||||
return $ uavs E.^. UserAvsPersonId
|
||||
return $ Set.fromList $ map E.unValue firmBlocks
|
||||
|
||||
let fltrIds
|
||||
| synchLevel >= 5 = id
|
||||
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
|
||||
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
|
||||
|
||||
when (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
||||
when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
||||
when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
|
||||
|
||||
-- | delayed exection of already received contact info
|
||||
dispatchJobSynchroniseByAvsDataContact :: AvsDataContact -> JobHandler UniWorX
|
||||
dispatchJobSynchroniseByAvsDataContact adc =
|
||||
JobHandlerException . runDB . void $ updateAvsUserByADC adc
|
||||
@ -1,70 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Model.Types.User where
|
||||
|
||||
import Import.NoModel
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
|
||||
type UserEduPersonPrincipalName = Text
|
||||
|
||||
|
||||
data SystemFunction
|
||||
= SystemExamOffice
|
||||
| SystemFaculty
|
||||
| SystemStudent
|
||||
| SystemPrinter
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||||
deriving anyclass (Universe, Finite, Hashable, NFData)
|
||||
|
||||
nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1
|
||||
pathPieceJSON ''SystemFunction
|
||||
pathPieceJSONKey ''SystemFunction
|
||||
derivePersistFieldPathPiece ''SystemFunction
|
||||
pathPieceBinary ''SystemFunction
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------------
|
||||
-- User related dataypes which are not stored in User itself, but in various places
|
||||
|
||||
data UserDrivingPermit = UserDrivingPermitB
|
||||
| UserDrivingPermitB01
|
||||
deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData)
|
||||
|
||||
instance Show UserDrivingPermit where
|
||||
show UserDrivingPermitB = "B"
|
||||
show UserDrivingPermitB01 = "B01" -- Brille notwendig
|
||||
|
||||
instance RenderMessage a UserDrivingPermit where
|
||||
renderMessage _foundation _languages = tshow
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 3
|
||||
} ''UserDrivingPermit
|
||||
derivePersistFieldJSON ''UserDrivingPermit
|
||||
nullaryPathPiece ''UserDrivingPermit $ camelToPathPiece' 3
|
||||
|
||||
data UserEyeExam = UserEyeExamSX
|
||||
| UserEyeExamS01
|
||||
deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData)
|
||||
|
||||
instance Show UserEyeExam where
|
||||
show UserEyeExamSX = "SX"
|
||||
show UserEyeExamS01 = "S01" -- Brille notwendig
|
||||
|
||||
instance RenderMessage a UserEyeExam where
|
||||
renderMessage _foundation _languages = tshow
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 3
|
||||
} ''UserEyeExam
|
||||
derivePersistFieldJSON ''UserEyeExam
|
||||
nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3
|
||||
|
||||
eyeExamFitsDrivingPermit :: UserEyeExam -> UserDrivingPermit -> Bool
|
||||
eyeExamFitsDrivingPermit UserEyeExamSX _ = True
|
||||
eyeExamFitsDrivingPermit UserEyeExamS01 UserDrivingPermitB01 = True
|
||||
eyeExamFitsDrivingPermit _ _ = False
|
||||
@ -1,271 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@frapor.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
|
||||
module Utils.Avs where
|
||||
|
||||
import Import.NoModel
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
|
||||
#ifndef DEVELOPMENT
|
||||
import Servant.Client.Core (requestPath)
|
||||
import UnliftIO.Concurrent (threadDelay)
|
||||
#endif
|
||||
|
||||
import Model.Types.Avs
|
||||
|
||||
|
||||
-------------
|
||||
-- AVS API --
|
||||
-------------
|
||||
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
|
||||
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
|
||||
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
|
||||
type AVSPersonContact = "InfoPersonContact" :> ReqBody '[JSON] AvsQueryContact :> Post '[JSON] AvsResponseContact
|
||||
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
|
||||
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
|
||||
|
||||
avsMaxSetLicenceAtOnce :: Int
|
||||
avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences as enforced by AVS (<80)
|
||||
|
||||
avsMaxQueryAtOnce :: Int
|
||||
avsMaxQueryAtOnce = 250 -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS (<500)
|
||||
|
||||
avsMaxQueryDelay :: Int
|
||||
avsMaxQueryDelay = 200000 -- microsecond to wait before sending another AVS query
|
||||
|
||||
|
||||
avsApi :: Proxy AVS
|
||||
avsApi = Proxy
|
||||
|
||||
{-
|
||||
-- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call
|
||||
data AvsQuery where
|
||||
AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
|
||||
, avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
|
||||
...
|
||||
}
|
||||
-> AvsQuery
|
||||
-}
|
||||
|
||||
data AvsQuery = AvsQuery
|
||||
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
|
||||
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
|
||||
, avsQueryContact :: forall m. MonadIO m => AvsQueryContact -> m (Either ClientError AvsResponseContact)
|
||||
, avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
|
||||
-- , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
|
||||
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
|
||||
}
|
||||
|
||||
makeLenses_ ''AvsQuery
|
||||
|
||||
|
||||
-- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response
|
||||
avsQueryAllLicences :: AvsQueryGetLicences
|
||||
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
|
||||
|
||||
|
||||
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
|
||||
#ifdef DEVELOPMENT
|
||||
mkAvsQuery _ _ _ = AvsQuery
|
||||
{ avsQueryPerson = return . Right . fakePerson
|
||||
, avsQueryStatus = return . Right . fakeStatus
|
||||
, avsQueryContact = return . Right . fakeContact
|
||||
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
|
||||
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
|
||||
}
|
||||
where
|
||||
fakeCard1 = AvsDataPersonCard True (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG") (AvsCardNo "6666") "4"
|
||||
fakeCard2 = AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot (Set.fromList ['F','A' ]) Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH") (AvsCardNo "7777") "4" -- AVSneo will report multiple companies using multiple cards with same card no
|
||||
fakeCard3 = AvsDataPersonCard True (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau mempty Nothing Nothing Nothing (Just "Fraport Facility Services GmbH") (AvsCardNo "7777") "4"
|
||||
fakeCard4 = AvsDataPersonCard True (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorGrün mempty Nothing Nothing Nothing (Just "Vollautomaten GmbH") (AvsCardNo "7777") "4"
|
||||
|
||||
fakePerson :: AvsQueryPerson -> AvsResponsePerson
|
||||
fakePerson =
|
||||
let
|
||||
sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) $ Set.singleton $ AvsDataPersonCard True Nothing Nothing AvsCardColorRot mempty Nothing Nothing Nothing Nothing (AvsCardNo "424242") "8"
|
||||
stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) $ Set.fromList [fakeCard1, fakeCard2]
|
||||
steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) $ Set.fromList [fakeCard2, fakeCard3, fakeCard4]
|
||||
sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
|
||||
sumpfi2 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) $ Set.fromList [fakeCard1, fakeCard2, fakeCard3, fakeCard4]
|
||||
sumpfi3 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
|
||||
in \case
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson steffen
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> AvsResponsePerson steffen
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson stephan
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> AvsResponsePerson sarah
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> AvsResponsePerson $ steffen <> sarah
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ steffen <> stephan
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "7777"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
|
||||
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
|
||||
_ -> AvsResponsePerson $ steffen <> sumpfi1
|
||||
|
||||
fakeStatus :: AvsQueryStatus -> AvsResponseStatus
|
||||
fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList [fakeCard1, fakeCard2, fakeCard3, fakeCard4]
|
||||
fakeStatus _ = AvsResponseStatus mempty
|
||||
fakeContact :: AvsQueryContact -> AvsResponseContact
|
||||
fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_)))
|
||||
| api == AvsPersonId 12345678 = AvsResponseContact $ Set.singleton jost
|
||||
| api == AvsPersonId 2 = AvsResponseContact $ Set.singleton vaupel
|
||||
| api == AvsPersonId 4 = AvsResponseContact $ Set.singleton barth
|
||||
| api == AvsPersonId 12345678 = AvsResponseContact $ Set.singleton heribert
|
||||
| api == AvsPersonId 604387 = AvsResponseContact $ Set.singleton heribert
|
||||
| api == AvsPersonId 604591 = AvsResponseContact $ Set.singleton heribert
|
||||
| otherwise = AvsResponseContact mempty
|
||||
where
|
||||
heribert = AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing (Just "sumpfi@tcs.ifi.lmu.de") Nothing (Just $ AvsInternalPersonalNo "57138"))
|
||||
(AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
||||
jost = AvsDataContact api (AvsPersonInfo "12345678" "Steffen" "Jost" 0 Nothing (Just "s.jost@fraport.de") (Just "069-69071706") Nothing)
|
||||
(AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
||||
vaupel = AvsDataContact api (AvsPersonInfo "2" "Sarah" "Vaupel" 1 Nothing (Just "sarah.vaupel@uniworx.de") (Just "069-69071706") Nothing)
|
||||
(AvsFirmInfo "UniWorX GmbH" 9 "UniWorX" (Just "81929") (Just "München") (Just "Germany") (Just "Somestr. 111") (Just "uniworx@uniworx.de") Nothing Nothing)
|
||||
barth = AvsDataContact api (AvsPersonInfo "4" "Stephan" "Barth" 2 Nothing (Just "stephan.barth@uniworx.de") (Just "069-69071706") Nothing)
|
||||
(AvsFirmInfo "UniWorX GmbH" 9 "UniWorX" Nothing Nothing Nothing Nothing Nothing (Just "sarah.vaupel@uniworx.de") Nothing)
|
||||
fakeContact _ = AvsResponseContact mempty
|
||||
#else
|
||||
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
|
||||
{ avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries
|
||||
liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
|
||||
, avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv
|
||||
, avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv
|
||||
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- NOTE: currently uses setLicencesAvs for splitting to ensure return of correctly set licences
|
||||
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
|
||||
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
|
||||
}
|
||||
where
|
||||
( rawQueryPerson
|
||||
:<|> rawQueryStatus
|
||||
:<|> rawQueryContact
|
||||
:<|> rawQueryGetLicences
|
||||
:<|> rawQuerySetLicences ) = client avsApi basicAuth
|
||||
catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson
|
||||
catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
|
||||
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
|
||||
catch404toEmpty other = other
|
||||
|
||||
splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Monoid (Unwrapped c))
|
||||
=> (a -> ClientM c) -> a -> ClientM c
|
||||
splitQuery rawQuery q
|
||||
| Set.size s <= 0 = return $ view _Unwrapped' mempty -- empty query, retun empty answer
|
||||
| avsMaxQueryAtOnce >= Set.size s = rawQuery q
|
||||
| otherwise = do
|
||||
-- logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM
|
||||
let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
|
||||
res1 <- rawQuery $ view _Unwrapped' avsid1
|
||||
liftIO $ threadDelay avsMaxQueryDelay
|
||||
res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
|
||||
return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
|
||||
where
|
||||
s = view _Wrapped' q
|
||||
#endif
|
||||
|
||||
-----------------------
|
||||
-- Utility Functions -- DEPRECTATED
|
||||
-----------------------
|
||||
|
||||
-- retrieve AvsDataPersonCard with longest validity for a given licence,
|
||||
-- first argument is a lower bound for avsDataValidTo, usually current day
|
||||
-- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
|
||||
-- getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
|
||||
-- getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
|
||||
-- where
|
||||
-- licence = licence2char licence'
|
||||
-- validLicenceCards = Set.filter cardMatch cards
|
||||
-- cardMatch AvsDataPersonCard{..} =
|
||||
-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
-- -- DEPRECTATED
|
||||
-- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
|
||||
-- getCompanyAddress card@AvsDataPersonCard{..}
|
||||
-- | Just street <- avsDataStreet
|
||||
-- , Just pcode <- avsDataPostalCode
|
||||
-- , Just city <- avsDataCity
|
||||
-- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
|
||||
-- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
|
||||
-- | otherwise = (Nothing, Nothing, Nothing)
|
||||
|
||||
-- -- From a set of card, choose the one with the most complete postal address.
|
||||
-- -- Returns company, postal address and the associated card where the address was taken from
|
||||
-- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
|
||||
-- guessLicenceAddress cards
|
||||
-- | Just c <- Set.lookupMax cards
|
||||
-- , card <- Set.foldr pickLicenceAddress c cards
|
||||
-- = getCompanyAddress card
|
||||
-- | otherwise = (Nothing, Nothing, Nothing)
|
||||
|
||||
-- hasAddress :: AvsDataPersonCard -> Bool
|
||||
-- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
|
||||
|
||||
-- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
|
||||
-- pickLicenceAddress a b
|
||||
-- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
-- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
-- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
-- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
-- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
|
||||
-- | avsDataCardColor a < avsDataCardColor b = b
|
||||
-- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
|
||||
-- | avsDataIssueDate a < avsDataIssueDate b = b
|
||||
-- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
|
||||
-- | avsDataValidTo a < avsDataValidTo b = b
|
||||
-- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
-- | a <= b = b -- respect natural Ord instance
|
||||
-- | otherwise = a
|
||||
-- where
|
||||
-- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
|
||||
-- pickBetter' = pickBetter a b
|
||||
-- licenceRollfeld = licence2char AvsLicenceRollfeld
|
||||
-- licenceVorfeld = licence2char AvsLicenceVorfeld
|
||||
|
||||
-- {- Note:
|
||||
-- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
|
||||
-- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
|
||||
-- compare a b = compareBy avsDataValid
|
||||
-- <> compareBy avsDataValidTo
|
||||
-- <> compareBy avsDataIssueDate
|
||||
-- ...
|
||||
-- where
|
||||
-- compareBy f = compare `on` f a b
|
||||
-- -}
|
||||
|
||||
-- Merges several answers by AvsPersonId, preserving all AvsPersonCards
|
||||
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeByPersonId = flip $ Set.foldr aux
|
||||
where
|
||||
aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
|
||||
|
||||
catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
|
||||
|
||||
mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeAvsDataPerson = Map.unionWithKey merger
|
||||
where
|
||||
merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
|
||||
merger api pa pb =
|
||||
let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
|
||||
pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
|
||||
in AvsDataPerson
|
||||
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
, avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
, avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
|
||||
, avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
}
|
||||
|
||||
pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
pickBy f x y | f x >= f y = x
|
||||
| otherwise = y
|
||||
|
||||
|
||||
@ -1,47 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Utils.Company where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
import Foundation.DB
|
||||
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
|
||||
-- DB Queries related to firms and supervision that are used in several places
|
||||
|
||||
|
||||
-- | check if a user is NOT associated with a company; false if company is null
|
||||
usrDoesNotBelong :: E.SqlExpr (E.Value UserId) -> E.SqlExpr (E.Value (Maybe CompanyId)) -> E.SqlExpr (E.Value Bool)
|
||||
usrDoesNotBelong uid fsh = E.isJust fsh E.&&. E.notExists (do
|
||||
uc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ uc E.^. UserCompanyUser E.==. uid
|
||||
E.&&. uc E.^. UserCompanyCompany E.=?. fsh
|
||||
)
|
||||
|
||||
-- | given a supervisionship, true if supervisor is NOT associated with the supervisionship-company
|
||||
missingCompanySupervisor :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
|
||||
missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
|
||||
|
||||
-- | given a supervisionship, true if client is NOT associated with the supervisionship-company
|
||||
missingCompanyClient :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
|
||||
missingCompanyClient us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
|
||||
|
||||
-- | once per day, check if there are supervisionships where supervisor or client are not associated witht the supervisionship-company
|
||||
areThereInsaneCompanySupervisions :: HandlerFor UniWorX (Bool, UTCTime)
|
||||
areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do
|
||||
now <- liftIO getCurrentTime
|
||||
res <- runDBRead $ E.selectExists $ do
|
||||
us <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ E.isJust (us E.^. UserSupervisorCompany)
|
||||
E.&&. (missingCompanySupervisor us E.||. missingCompanyClient us)
|
||||
$logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
|
||||
return (res,now)
|
||||
@ -1,506 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
-- also see Utils.Persist
|
||||
|
||||
module Utils.DB where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (addMessageI)
|
||||
|
||||
import qualified Data.Monoid as Monoid (First())
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
import Utils
|
||||
import Control.Lens
|
||||
import Control.Lens.Extras (is)
|
||||
|
||||
import Control.Monad.Catch hiding (bracket)
|
||||
|
||||
import qualified Utils.Pool as Custom
|
||||
|
||||
import Database.Persist.Sql (runSqlConn) -- , updateWhereCount)
|
||||
|
||||
import GHC.Stack (HasCallStack, CallStack, callStack)
|
||||
|
||||
-- import Language.Haskell.TH.Lift
|
||||
|
||||
-- import Control.Monad.Fix (MonadFix)
|
||||
-- import Control.Monad.Fail (MonadFail)
|
||||
|
||||
-- import Control.Monad.Trans.Reader (withReaderT)
|
||||
|
||||
-- | Obtain a record projection from an EntityField
|
||||
getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -> typ
|
||||
getFieldEnt = view . fieldLens
|
||||
|
||||
getField :: PersistEntity record => EntityField record typ -> record -> typ
|
||||
getField = view . fieldLensVal
|
||||
|
||||
-- | Obtain a lens from an EntityField
|
||||
fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ
|
||||
fieldLensVal f = entityLens . fieldLens f
|
||||
where
|
||||
entityLens :: Lens' record (Entity record)
|
||||
entityLens = lens getVal setVal
|
||||
getVal :: record -> Entity record
|
||||
getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
|
||||
setVal :: record -> Entity record -> record
|
||||
setVal _ = entityVal
|
||||
|
||||
|
||||
emptyOrIn :: PersistField typ
|
||||
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
|
||||
emptyOrIn criterion testSet
|
||||
| Set.null testSet = E.val True
|
||||
| otherwise = criterion `E.in_` E.valList (Set.toList testSet)
|
||||
|
||||
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
|
||||
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
|
||||
|
||||
getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
=> Unique record -> ReaderT backend m (Entity record)
|
||||
getJustBy u = getBy u >>= maybe
|
||||
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
||||
return
|
||||
|
||||
getKeyBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m (Maybe (Key record))
|
||||
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
||||
|
||||
getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyJustBy u = getKeyBy u >>= maybe
|
||||
(throwM . PersistForeignConstraintUnmet $ tshow u)
|
||||
return
|
||||
|
||||
getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
||||
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
|
||||
=> Key record -> ReaderT backend m (Entity record)
|
||||
getEntity404 k = Entity k <$> get404 k
|
||||
|
||||
notExists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m Bool
|
||||
notExists = fmap not . exists
|
||||
|
||||
existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
existsBy = fmap (is _Just) . getKeyBy
|
||||
|
||||
existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
|
||||
=> Unique record -> ReaderT backend m ()
|
||||
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
|
||||
|
||||
existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> Key record -> ReaderT backend m Bool
|
||||
existsKey = exists . pure . (persistIdField ==.)
|
||||
|
||||
-- -- Available in persistent since 2.11.0.0
|
||||
-- exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
-- => [Filter record] -> ReaderT backend m Bool
|
||||
-- exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
|
||||
|
||||
exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
||||
=> [Filter record] -> ReaderT backend m ()
|
||||
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
|
||||
|
||||
existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
|
||||
=> Key record -> ReaderT backend m ()
|
||||
existsKey404 = bool notFound (return ()) <=< existsKey
|
||||
|
||||
-- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result
|
||||
-- getByPeseudoUnique
|
||||
getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> [Filter record] -> ReaderT backend m (Maybe (Entity record))
|
||||
getByFilter crit =
|
||||
selectList crit [LimitTo 2] <&> \case
|
||||
[singleEntity] -> Just singleEntity
|
||||
_ -> Nothing -- not existing or not unique
|
||||
|
||||
getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> [Filter record] -> ReaderT backend m (Maybe (Key record))
|
||||
getKeyByFilter crit =
|
||||
selectKeysList crit [LimitTo 2] <&> \case
|
||||
[singleKey] -> Just singleKey
|
||||
_ -> Nothing -- not existing or not unique
|
||||
|
||||
|
||||
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
|
||||
=> Unique record -> [Update record] -> ReaderT backend m ()
|
||||
updateBy uniq updates = do
|
||||
key <- getKeyBy uniq
|
||||
for_ key $ flip update updates
|
||||
|
||||
-- | update and retrieve an entity. Will throw an error if the key is updaded
|
||||
updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record)
|
||||
updateGetEntity k = fmap (Entity k) . updateGet k
|
||||
|
||||
-- | insert or replace a record based on a single uniqueness constraint
|
||||
-- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record
|
||||
replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend)
|
||||
=> record -> ReaderT backend m ()
|
||||
replaceBy r = do
|
||||
u <- onlyUnique r
|
||||
deleteBy u
|
||||
insert_ r
|
||||
|
||||
-- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
|
||||
-- and 'Just key' for the successfully replaced record
|
||||
uniqueReplace :: ( MonadIO m
|
||||
, Eq (Unique record)
|
||||
, PersistRecordBackend record backend
|
||||
, PersistUniqueWrite backend
|
||||
)
|
||||
=> Key record -> record -> ReaderT backend m (Maybe (Key record))
|
||||
uniqueReplace key datumNew = flipMaybe key <$> myReplaceUnique key datumNew
|
||||
|
||||
-- | Identical to 'Database.Persist.Class', except for the better type signature (original requires Eq record which is not needed anyway)
|
||||
myReplaceUnique :: ( MonadIO m
|
||||
, Eq (Unique record)
|
||||
, PersistRecordBackend record backend
|
||||
, PersistUniqueWrite backend
|
||||
)
|
||||
=> Key record -> record -> ReaderT backend m (Maybe (Unique record))
|
||||
myReplaceUnique key datumNew = getJust key >>= replaceOriginal
|
||||
where
|
||||
uniqueKeysNew = persistUniqueKeys datumNew
|
||||
replaceOriginal original = do
|
||||
conflict <- checkUniqueKeys changedKeys
|
||||
case conflict of
|
||||
Nothing -> replace key datumNew >> return Nothing
|
||||
(Just conflictingKey) -> return $ Just conflictingKey
|
||||
where
|
||||
changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
|
||||
uniqueKeysOriginal = persistUniqueKeys original
|
||||
|
||||
replaceEntity :: ( MonadIO m
|
||||
, PersistRecordBackend record backend
|
||||
, PersistStoreWrite backend
|
||||
)
|
||||
=> Entity record -> ReaderT backend m ()
|
||||
replaceEntity Entity{..} = replace entityKey entityVal
|
||||
|
||||
-- Notes on upsertBy:
|
||||
-- * Unique denotes old record
|
||||
-- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists
|
||||
-- * Use Database.Esqueleto.PostgreSQL.upsertBy for more elaborate conflict updates
|
||||
|
||||
-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint
|
||||
upsertBySafe :: ( MonadIO m
|
||||
, PersistEntity record
|
||||
, PersistUniqueWrite backend
|
||||
, PersistEntityBackend record ~ BaseBackend backend
|
||||
)
|
||||
=> Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record))
|
||||
upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq)
|
||||
where
|
||||
do_upd Entity{entityKey = oid, entityVal = oldr} = do
|
||||
delete oid
|
||||
insertUnique $ upd oldr
|
||||
|
||||
upsertBy_ :: ( MonadIO m
|
||||
, PersistEntity record
|
||||
, PersistUniqueWrite backend
|
||||
, PersistEntityBackend record ~ BaseBackend backend
|
||||
)
|
||||
=> Unique record -> record -> [Update record] -> ReaderT backend m ()
|
||||
upsertBy_ = ((void .) .) . upsertBy
|
||||
|
||||
checkUniqueKeys :: ( MonadIO m
|
||||
, PersistUniqueRead backend
|
||||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> [Unique record] -> ReaderT backend m (Maybe (Unique record))
|
||||
checkUniqueKeys [] = return Nothing
|
||||
checkUniqueKeys (x:xs) = do
|
||||
y <- getBy x
|
||||
case y of
|
||||
Nothing -> checkUniqueKeys xs
|
||||
Just _ -> return (Just x)
|
||||
|
||||
-- Backport from version persistent-2.14.6.3
|
||||
insertUnique_ :: ( MonadIO m
|
||||
, PersistEntity record
|
||||
, PersistUniqueWrite backend
|
||||
, PersistEntityBackend record ~ BaseBackend backend
|
||||
)
|
||||
=> record -> ReaderT backend m (Maybe ())
|
||||
insertUnique_ datum = do
|
||||
conflict <- checkUnique datum
|
||||
case conflict of
|
||||
Nothing -> Just <$> insert_ datum
|
||||
Just _ -> return Nothing
|
||||
|
||||
put :: ( MonadIO m
|
||||
, PersistUniqueWrite backend
|
||||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> record -> ReaderT backend m (Key record)
|
||||
-- ^ `insert`, but remove all records with matching uniqueness constraints first
|
||||
put v = do
|
||||
forM_ (persistUniqueKeys v) deleteBy
|
||||
insert v
|
||||
|
||||
-- | Deprecated, use selectFirst instead.
|
||||
selectMaybe :: forall record backend m.
|
||||
( MonadIO m
|
||||
, PersistQueryRead backend
|
||||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> [Filter record] -> [SelectOpt record]
|
||||
-> ReaderT backend m (Maybe (Entity record))
|
||||
selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts')
|
||||
where opts' = filter (not . isLimit) opts
|
||||
isLimit = \case
|
||||
LimitTo _ -> True
|
||||
_other -> False
|
||||
|
||||
|
||||
type DBConnLabel = CallStack
|
||||
|
||||
customRunSqlPool :: (HasCallStack, MonadUnliftIO m, BackendCompatible SqlBackend backend)
|
||||
=> ReaderT backend m a
|
||||
-> Custom.Pool' m DBConnLabel c backend
|
||||
-> m a
|
||||
customRunSqlPool act p = customRunSqlPool' act p callStack
|
||||
|
||||
customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
|
||||
=> ReaderT backend m a
|
||||
-> Custom.Pool' m DBConnLabel c backend
|
||||
-> CallStack
|
||||
-> m a
|
||||
customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act
|
||||
|
||||
|
||||
class WithRunDB backend m' m | m -> backend m' where
|
||||
useRunDB :: ReaderT backend m' a -> m a
|
||||
|
||||
instance WithRunDB backend m (ReaderT backend m) where
|
||||
useRunDB = id
|
||||
|
||||
-- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special:
|
||||
-- updateWithMessage
|
||||
-- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend
|
||||
-- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)]))
|
||||
-- => url -- where to redirect, if changes were mage
|
||||
-- -> [Filter val] -- update filter
|
||||
-- -> [Update val] -- actual update
|
||||
-- -> a -- expected updates
|
||||
-- -> (a -> msg) -- message to add with number of actual changes
|
||||
-- -> HandlerFor site ()
|
||||
-- updateWithMessage route flt upd no_req msg = do
|
||||
-- (fromIntegral -> oks) <- runDB $ updateWhereCount flt upd
|
||||
-- let mkind = if oks < no_req || no_req <= 0 then Warning else Success
|
||||
-- addMessageI mkind $ msg oks
|
||||
-- when (oks > 0) $ do -- reload to ensure updates are displayed
|
||||
-- getps <- reqGetParams <$> getRequest
|
||||
-- redirect (route, getps)
|
||||
|
||||
|
||||
-- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b }
|
||||
|
||||
-- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))
|
||||
-- _DBRunner' = iso fromDBRunner' toDBRunner
|
||||
-- where
|
||||
-- fromDBRunner' :: forall site.
|
||||
-- DBRunner site
|
||||
-- -> DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
|
||||
|
||||
-- toDBRunner :: forall site.
|
||||
-- DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-- -> DBRunner site
|
||||
-- toDBRunner DBRunner'{..} = DBRunner runDBRunner'
|
||||
|
||||
-- fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site)
|
||||
-- fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend)
|
||||
|
||||
-- newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a }
|
||||
-- deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m)
|
||||
|
||||
-- instance MonadTrans (CachedDBRunner backend) where
|
||||
-- lift act = CachedDBRunner (const act)
|
||||
|
||||
-- instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where
|
||||
-- type HandlerSite (CachedDBRunner backend m) = HandlerSite m
|
||||
-- type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m
|
||||
|
||||
-- liftHandler = lift . liftHandler
|
||||
-- liftSubHandler = lift . liftSubHandler
|
||||
|
||||
-- instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where
|
||||
-- useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act)
|
||||
|
||||
-- runCachedDBRunnerSTM :: MonadUnliftIO m
|
||||
-- => m (DBRunner' backend m)
|
||||
-- -> CachedDBRunner backend m a
|
||||
-- -> m a
|
||||
-- runCachedDBRunnerSTM doAcquire act = do
|
||||
-- doAcquireLock <- newTMVarIO ()
|
||||
-- runnerTMVar <- newEmptyTMVarIO
|
||||
|
||||
-- let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do
|
||||
-- cachedRunner <- atomically $ tryReadTMVar runnerTMVar
|
||||
-- case cachedRunner of
|
||||
-- Just cachedRunner' -> return cachedRunner'
|
||||
-- Nothing -> do
|
||||
-- runner <- doAcquire
|
||||
-- void . atomically $ tryPutTMVar runnerTMVar runner
|
||||
-- return runner
|
||||
-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
|
||||
|
||||
-- runCachedDBRunnerUsing act getRunnerNoLock
|
||||
|
||||
|
||||
|
||||
-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
|
||||
data CheckUpdate record iraw =
|
||||
forall typ. (Eq typ, PersistField typ) =>
|
||||
CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting (also use for typ ~ Maybe typ')
|
||||
| forall typ. (Eq typ, PersistField typ) =>
|
||||
CheckUpdateMay (EntityField record (Maybe typ)) (Getting (Maybe typ) iraw (Maybe typ)) -- Special case, when `typ` is optional everywhere, forces update of Nothing to Just values
|
||||
| forall typ. (Eq typ, PersistField typ) =>
|
||||
CheckUpdateOpt (EntityField record typ) (Getting (Monoid.First typ) iraw typ) -- Special case, when `typ` is optional for the lens, but not optional in DB.
|
||||
|
||||
-- deriving instance Lift (CheckUpdate record iraw) -- not possible, seee Handler.Utils.AvsUpdate for a workaround
|
||||
-- instance Lift (CheckUpdate record iraw) where
|
||||
-- lift = $(makeLift ''CheckUpdate)
|
||||
|
||||
-- | checks if an update would be performed, if a new different value would be presented. Should agree with `mkUpdate` familiy of functions
|
||||
mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool
|
||||
mayUpdate ent (Just old) (CheckUpdate up l)
|
||||
| let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
= oldval == entval
|
||||
mayUpdate ent (Just old) (CheckUpdateMay up l)
|
||||
| let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
= isNothing entval || oldval == entval
|
||||
mayUpdate ent (Just old) (CheckUpdateOpt up l)
|
||||
| Just oldval <- old ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
= oldval == entval
|
||||
mayUpdate _ _ _ = False
|
||||
|
||||
-- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value,
|
||||
-- an update is returned, if the current value is identical to the old value, which changed in the new raw data
|
||||
mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
|
||||
mkUpdate ent new (Just old) (CheckUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= Just (up =. newval)
|
||||
mkUpdate ent new (Just old) (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
|
||||
= Just (up =. newval)
|
||||
mkUpdate ent new (Just old) (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, Just oldval <- old ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= Just (up =. newval)
|
||||
mkUpdate _ _ _ _ = Nothing
|
||||
|
||||
-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
|
||||
mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
|
||||
mkUpdate' ent new Nothing = mkUpdateDirect ent new
|
||||
mkUpdate' ent new just = mkUpdate ent new just
|
||||
|
||||
-- | Like `mkUpdate` but performs the update without comparison to a previous older value, whenever current entity value and new value are different
|
||||
mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record)
|
||||
mkUpdateDirect ent new (CheckUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= Just (up =. newval)
|
||||
mkUpdateDirect ent new (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= Just (up =. newval)
|
||||
mkUpdateDirect ent new (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= Just (up =. newval)
|
||||
mkUpdateDirect _ _ _ = Nothing
|
||||
|
||||
-- | Unconditionally update a record through CheckUpdate
|
||||
updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record
|
||||
updateRecord ent new (CheckUpdate up l) =
|
||||
let newval = new ^. l
|
||||
lensRec = fieldLensVal up
|
||||
in ent & lensRec .~ newval
|
||||
updateRecord ent new (CheckUpdateMay up l) =
|
||||
let newval = new ^. l
|
||||
lensRec = fieldLensVal up
|
||||
in ent & lensRec .~ newval
|
||||
updateRecord ent new (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
= ent & fieldLensVal up .~ newval
|
||||
| otherwise
|
||||
= ent
|
||||
|
||||
-- | like mkUpdate' but only returns the update if the new value would be unique
|
||||
-- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record))
|
||||
mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
|
||||
=> record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))
|
||||
mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new Nothing (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new Nothing (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new (Just old) (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, Just oldval <- old ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' _ _ _ _ = return Nothing
|
||||
@ -1,102 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Utils.Mail where
|
||||
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
-- | domains used by LDAP accounts
|
||||
fraportMailDomains :: [Text]
|
||||
fraportMailDomains = ["@fraport.de"] -- <&> foldCase only!
|
||||
|
||||
-- | returns the part before the @ symbol of an email address that ends with a fraport domain, preserving case
|
||||
-- eg. getFraportLogin "E1234@fraport.de" == Just "E1234"
|
||||
-- getFraportLogin "S.Guy@fraport.de" == Just "S.Guy"
|
||||
-- getFraportLogin "S.Guy@elsewhere.com" == Nothing
|
||||
-- Use CI.traverse getFraportLogin :: CI Text -> Maybe (CI Text)
|
||||
-- CI.traverse getFraportLogin "S.Jost@Fraport.de" == Just "S.Jost"
|
||||
getFraportLogin :: Text -> Maybe Text
|
||||
getFraportLogin email = orgCase <$> lowerCaseLogin
|
||||
where
|
||||
orgCase = flip Text.take email . Text.length
|
||||
lowerCaseLogin = firstJust (flip Text.stripSuffix $ foldCase email) fraportMailDomains
|
||||
|
||||
-- | check that an email is valid and that it is not an E-account that nobody reads
|
||||
-- also see `Handler.Utils.Users.getUserEmail` for Tests accepting User Type
|
||||
validEmail :: Text -> Bool -- Email = Text
|
||||
validEmail email = validRFC5322 && not invalidFraport
|
||||
where
|
||||
validRFC5322 = Email.isValid $ encodeUtf8 email
|
||||
invalidFraport = case getFraportLogin email of
|
||||
Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin -- Emails like E1234@fraport.de or 012345!fraport.de are not read
|
||||
Nothing -> False
|
||||
|
||||
validEmail' :: CI Text -> Bool -- UserEmail = CI Text
|
||||
validEmail' = validEmail . CI.original
|
||||
|
||||
-- | returns the first valid Email, if any
|
||||
pickValidEmail :: [Text] -> Maybe Text
|
||||
pickValidEmail = find validEmail
|
||||
|
||||
-- | returns the first valid Email, if any
|
||||
pickValidEmail' :: [CI Text] -> Maybe (CI Text)
|
||||
pickValidEmail' = find validEmail'
|
||||
|
||||
-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
|
||||
pickValidUserEmail :: CI Text -> CI Text -> CI Text
|
||||
pickValidUserEmail x y
|
||||
| validEmail' x = x
|
||||
| otherwise = y
|
||||
|
||||
-- | returns first valid email address or none if none are valid
|
||||
pickValidUserEmail' :: CI Text -> CI Text -> Maybe (CI Text)
|
||||
pickValidUserEmail' x y
|
||||
| validEmail' x = Just x
|
||||
| validEmail' y = Just y
|
||||
| otherwise = Nothing
|
||||
|
||||
|
||||
--------------------
|
||||
-- Telephone Utils
|
||||
|
||||
-- | normalize phone numbers
|
||||
canonicalPhone :: Text -> Text
|
||||
canonicalPhone pn
|
||||
| Just pn01 <- Text.stripPrefix "01" pn
|
||||
= german_mobile pn01
|
||||
| Just pn01 <- Text.stripPrefix "+491" pn
|
||||
= german_mobile pn01
|
||||
| Just pn00 <- Text.stripPrefix "00" pn
|
||||
= Text.cons '+' $ Text.map repl_nondigit pn00
|
||||
| Just ('0', pn0) <- Text.uncons pn
|
||||
, Just (snr, _ ) <- Text.uncons pn0
|
||||
, snr /= '0'
|
||||
, Char.isDigit snr
|
||||
= "+49 " <> Text.map repl_nondigit pn0
|
||||
| otherwise
|
||||
= Text.map repl_nondigit pn
|
||||
where
|
||||
-- split_area :: Text -> Char -> Int -> Text -> Text
|
||||
-- split_area c f p n =
|
||||
-- let (area,sufx) = Text.splitAt p $ Text.filter Char.isDigit n
|
||||
-- in c <> Text.cons f area <> Text.cons ' ' sufx
|
||||
|
||||
german_mobile :: Text -> Text
|
||||
--german_mobile = split_area "+49" '1' 2
|
||||
german_mobile wpx =
|
||||
let (area,endnr) = Text.splitAt 2 $ Text.filter Char.isDigit wpx
|
||||
in "+49 1" <> area <> Text.cons ' ' endnr
|
||||
|
||||
repl_nondigit :: Char -> Char
|
||||
repl_nondigit c
|
||||
| Char.isDigit c = c
|
||||
| c == '+' = '+'
|
||||
| otherwise = ' '
|
||||
@ -1,51 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Utils.Pandoc where
|
||||
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import Data.Either (fromRight)
|
||||
-- import qualified Data.Char as Char
|
||||
-- import qualified Data.Text as Text
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
import Text.Blaze (toMarkup)
|
||||
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
import qualified Text.Pandoc as P
|
||||
|
||||
|
||||
markdownToHtml :: Html -> Either P.PandocError Html
|
||||
markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
|
||||
|
||||
htmlToPlainText :: Html -> Either P.PandocError Text
|
||||
htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml markdownReaderOptions (toStrict $ renderHtml html)
|
||||
|
||||
plainTextToHtml :: Text -> Html
|
||||
plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $
|
||||
P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
|
||||
-- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code
|
||||
-- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
|
||||
|
||||
plainHtmlToHtml :: Text -> Html
|
||||
plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $
|
||||
P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text
|
||||
|
||||
|
||||
|
||||
htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
|
||||
htmlReaderOptions = markdownReaderOptions
|
||||
markdownReaderOptions = def
|
||||
{ P.readerExtensions = P.pandocExtensions
|
||||
& P.enableExtension P.Ext_hard_line_breaks
|
||||
& P.enableExtension P.Ext_autolink_bare_uris
|
||||
, P.readerTabStop = 2
|
||||
}
|
||||
|
||||
markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
|
||||
markdownWriterOptions = def
|
||||
{ P.writerExtensions = P.readerExtensions markdownReaderOptions
|
||||
, P.writerTabStop = P.readerTabStop markdownReaderOptions
|
||||
}
|
||||
htmlWriterOptions = markdownWriterOptions
|
||||
@ -1,32 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile?
|
||||
-- TODO: consider merging with Handler.Utils.Users?
|
||||
module Utils.Postal
|
||||
( validPostAddress, validPostAddressText
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Model.Types.Markup
|
||||
|
||||
import Data.Char
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
|
||||
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
|
||||
validPostAddress :: Maybe StoredMarkup -> Bool
|
||||
validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
|
||||
validPostAddress _ = False
|
||||
|
||||
validPostAddressText :: Text -> Bool
|
||||
validPostAddressText = validPostAddressLazyText . LT.fromStrict
|
||||
|
||||
validPostAddressLazyText :: LT.Text -> Bool
|
||||
validPostAddressLazyText addr
|
||||
| Just _ <- LT.find isLetter addr
|
||||
, Just _ <- LT.find isNumber addr
|
||||
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
|
||||
= 1 < length (LT.lines addr)
|
||||
validPostAddressLazyText _ = False
|
||||
@ -1,182 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Utils.Print.RenewQualification where
|
||||
|
||||
import Import
|
||||
import Text.Hamlet
|
||||
|
||||
import Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.FileEmbed (embedFile)
|
||||
|
||||
import Utils.Print.Letters
|
||||
import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
|
||||
import Handler.Utils.Qualification (computeNewValidDate)
|
||||
|
||||
|
||||
defaultNotice :: Lang -> Bool -> Maybe Int -> Text -> Text -> Text -> [Text]
|
||||
defaultNotice l renewAuto elimit qualName qualShort newExpire =
|
||||
[intro <> renewal <> bequick <> outro, still_needed, switch_lang] -- list of separate paragraphs
|
||||
where
|
||||
intro :: Text
|
||||
| isDe l = [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden.
|
||||
Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben. |]
|
||||
| otherwise = [st|A certificate for your records can only be generated immediately after a successful test.
|
||||
The certificate will be issued for the user login. The certificate and this letter may then prove that you have passed. |]
|
||||
renewal :: Text
|
||||
| not renewAuto = mempty
|
||||
| isDe l = [st|Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{newExpire}. |]
|
||||
| otherwise = [st|Upon successful completion of the training, the expiry date will automatically be extended until #{newExpire}. |]
|
||||
bequick :: Text
|
||||
| isDe l = "Wir empfehlen die Schulung zeitnah durchzuführen. "
|
||||
| otherwise = "We recommend completing the training as soon as possible. "
|
||||
limit :: Text
|
||||
| Just n <- elimit, n > 0, isDe l = [st|innerhalb von #{n} Versuchen |]
|
||||
| Just n <- elimit, n > 0 = [st|within #{n} attempts |]
|
||||
| otherwise = mempty
|
||||
praxis :: Text
|
||||
| renewAuto = mempty
|
||||
| isDe l = "der Praxisteil und "
|
||||
| otherwise = "the practical part and "
|
||||
outro :: Text
|
||||
| isDe l = [st|Sollte bis zum Ablaufdatum #{praxis}das E-Learning nicht #{limit}erfolgreich abgeschlossen sein, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fraport Fahrerausbildung absolviert werden.|]
|
||||
| otherwise = [st|The licence irrevocably expires, if #{praxis}the e-learning is not successfully completed #{limit}by the expiry date. In this case, regaining licence "#{qualShort}" requires the completing of a normal training course #{qualName} again, as if no prior experience existed.|]
|
||||
still_needed :: Text
|
||||
| isDe l = "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fraport Fahrerausbildung."
|
||||
| otherwise = "Please inform us, if this driving licence is no longer required."
|
||||
switch_lang :: Text
|
||||
| isDe l = "(Please contact us if you prefer letters in English.)"
|
||||
| otherwise = "(Kontaktieren Sie uns bitte, um zukünftige Briefe von uns in deutscher Sprache zu erhalten.)"
|
||||
|
||||
|
||||
isAnyDrivingLicence :: Text -> Maybe Text
|
||||
-- isAnyDrivingLicence = firstJust (Text.stripSuffix "führerschein") . Text.words . Text.replace "-" " " . Text.replace "+" ""
|
||||
isAnyDrivingLicence = firstJust (Text.stripSuffix "führerschein") . Text.words . Text.map anyNonAlphaToBlank
|
||||
|
||||
anyNonAlphaToBlank :: Char -> Char
|
||||
anyNonAlphaToBlank c
|
||||
| Char.isAlpha c
|
||||
= c
|
||||
| otherwise = ' '
|
||||
|
||||
qualificationText :: Lang -> Text -> Text -> (Text, Text, Text) -- (qarea, qformal, qlicence) i.e. (Rollfeld, Rollfeldfahrberechtigung, Rollfeldführerschein) translated
|
||||
qualificationText l _qName "GSS"
|
||||
| isDe l
|
||||
= ("Gabelstapler", "Fahrberechtigung Gabelstapler", "Gabelstaplerführerschein")
|
||||
| otherwise
|
||||
= ("forklift", "forklift driving licence", "forklift driving licence")
|
||||
qualificationText l qName@(isAnyDrivingLicence -> Just qPrefix) qShort
|
||||
| isDe l
|
||||
= (qPrefix, [st|Fahrberechtigung „#{qShort}“|], qName)
|
||||
| qShort == "F"
|
||||
= ("apron", [st|driving licence "#{qShort}"|], "apron driving licence")
|
||||
| Text.isPrefixOf "R" qShort
|
||||
= ("maneuvering area", [st|driving licence "#{qShort}"|], "maneuvering area driving licence")
|
||||
| otherwise
|
||||
= (qPrefix, qPrefix <> " driving licence", qName)
|
||||
qualificationText l qName qShort
|
||||
| isDe l
|
||||
= (qShort, [st|Fahrberechtigung „#{qShort}“|], qName)
|
||||
| otherwise
|
||||
= (qShort, [st|driving licence "#{qShort}"|], qName)
|
||||
|
||||
|
||||
data LetterRenewQualification = LetterRenewQualification
|
||||
{ lmsLogin :: LmsIdent
|
||||
, lmsPin :: Text
|
||||
, qualHolderID :: UserId
|
||||
, qualHolderDN :: UserDisplayName
|
||||
, qualHolderSN :: UserSurname
|
||||
, qualExpiry :: Day
|
||||
, qualId :: QualificationId
|
||||
, qualName :: Text
|
||||
, qualShort :: Text
|
||||
, qualSchool :: SchoolId
|
||||
, qualDuration :: Maybe Int
|
||||
, qualRenewAuto :: Bool
|
||||
, qualELimit :: Maybe Int
|
||||
, isReminder :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- this datatype is specific to this letter only, and just to avoid code duplication for derived data or constants
|
||||
data LetterRenewQualificationData = LetterRenewQualificationData { lmsUrl, lmsUrlLogin, lmsUrlPassword, lmsIdent :: Text }
|
||||
deriving (Eq, Show)
|
||||
|
||||
letterRenewalQualificationFData :: LetterRenewQualification -> LetterRenewQualificationData
|
||||
letterRenewalQualificationFData LetterRenewQualification{lmsLogin, lmsPin} = LetterRenewQualificationData{..}
|
||||
where
|
||||
lmsUrl = "drive.fraport.de"
|
||||
lmsUrlLogin = "https://" <> lmsUrl <> "/?username=" <> lmsIdent
|
||||
lmsUrlPassword = lmsUrlLogin <> "&password=" <> lmsPin
|
||||
lmsIdent = getLmsIdent lmsLogin
|
||||
|
||||
|
||||
instance MDLetter LetterRenewQualification where
|
||||
encryptPDFfor _ = PasswordUnderling
|
||||
getLetterKind _ = PinLetter
|
||||
getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
|
||||
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
|
||||
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
|
||||
getMailBody l@LetterRenewQualification{..} = Just $ \DateTimeFormatter{ format } ->
|
||||
let LetterRenewQualificationData{..} = letterRenewalQualificationFData l
|
||||
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
|
||||
|
||||
letterMeta l@LetterRenewQualification{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =
|
||||
let LetterRenewQualificationData{..} = letterRenewalQualificationFData l
|
||||
isSupervised = rcvrId /= qualHolderID
|
||||
newExpire = computeNewValidDate (fromMaybe 0 qualDuration) qualExpiry
|
||||
(qArea, qFormal, qLicence) = qualificationText lang qualName qualShort
|
||||
in mkMeta $
|
||||
guardMonoid isSupervised
|
||||
[ toMeta "supervisor" userDisplayName
|
||||
] <>
|
||||
guardMonoid isReminder
|
||||
[ toMeta "reminder" ("reminder"::Text)
|
||||
] <>
|
||||
guardMonoid (not qualRenewAuto)
|
||||
[ toMeta "practical" True -- note: definied or undefined matters, bool value is unimportant
|
||||
] <>
|
||||
[ toMeta "lang" lang
|
||||
, toMeta "login" lmsIdent
|
||||
, toMeta "pin" lmsPin
|
||||
, toMeta "examinee" qualHolderDN
|
||||
, toMeta "subject-meta" qualHolderDN
|
||||
, toMeta "expiry" (format SelFormatDate qualExpiry)
|
||||
, mbMeta "validduration" (show <$> qualDuration)
|
||||
, toMeta "url-text" lmsUrl
|
||||
, toMeta "url" lmsUrlPassword -- ok for PDF, since it contains the PIN already
|
||||
, toMeta "notice" $ defaultNotice lang qualRenewAuto qualELimit qualName qualShort $ format SelFormatDate newExpire
|
||||
, toMeta "de-subject" [st|Verlängerung Fahrberechtigung „#{qualShort}“ (#{qualName})|]
|
||||
, toMeta "en-subject" [st|Renewal of driving licence "#{qualShort}" (#{qualName})|]
|
||||
, toMeta "de-opening" $ bool [st|Guten Tag #{qualHolderDN},|] [st|Guten Tag #{userDisplayName},|] isSupervised
|
||||
, toMeta "en-opening" $ bool [st|Dear #{qualHolderDN},|] [st|Dear #{userDisplayName},|] isSupervised
|
||||
, toMeta "qarea" qArea
|
||||
, toMeta "qformal" qFormal
|
||||
, toMeta "qlicence" qLicence
|
||||
] -- NOTE: use [st|some simple text with interpolation|]
|
||||
|
||||
getPJId LetterRenewQualification{..} =
|
||||
PrintJobIdentification
|
||||
{ pjiName = bool "Renewal" "Renewal Reminder" isReminder
|
||||
, pjiApcAcknowledge = "lms-" <> getLmsIdent lmsLogin
|
||||
, pjiRecipient = Nothing -- to be filled later
|
||||
, pjiSender = Nothing
|
||||
, pjiAffected = Just qualHolderID
|
||||
, pjiCourse = Nothing
|
||||
, pjiQualification = Just qualId
|
||||
, pjiLmsUser = Just lmsLogin
|
||||
, pjiFileName = "renew_" <> CI.original (unSchoolKey qualSchool) <> "-" <> qualShort <> "_" <> qualHolderSN
|
||||
-- let nameRecipient = abbrvName <$> recipient
|
||||
-- nameSender = abbrvName <$> sender
|
||||
-- nameCourse = CI.original . courseShorthand <$> course
|
||||
-- nameQuali = CI.original . qualificationShorthand <$> quali
|
||||
-- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
}
|
||||
@ -1,113 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Utils.Users
|
||||
( AuthenticationKind(..)
|
||||
, AddUserData(..)
|
||||
, addNewUser, addNewUserDB
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Universe, Finite)
|
||||
--instance Universe AuthenticationKind
|
||||
--instance Finite AuthenticationKind
|
||||
embedRenderMessage ''UniWorX ''AuthenticationKind id
|
||||
nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
|
||||
|
||||
mkAuthMode :: AuthenticationKind -> AuthenticationMode
|
||||
mkAuthMode AuthKindLDAP = AuthLDAP
|
||||
mkAuthMode AuthKindPWHash = AuthPWHash ""
|
||||
mkAuthMode AuthKindNoLogin = AuthNoLogin
|
||||
|
||||
{-
|
||||
classifyAuth :: AuthenticationMode -> AuthenticationKind
|
||||
classifyAuth AuthLDAP = AuthKindLDAP
|
||||
classifyAuth AuthPWHash{} = AuthKindPWHash
|
||||
classifyAuth AuthNoLogin = AuthKindNoLogin
|
||||
-}
|
||||
|
||||
data AddUserData = AddUserData
|
||||
{ audTitle :: Maybe Text
|
||||
, audFirstName :: Text
|
||||
, audSurname :: UserSurname
|
||||
, audDisplayName :: UserDisplayName
|
||||
, audDisplayEmail :: UserEmail
|
||||
, audMatriculation :: Maybe UserMatriculation
|
||||
, audSex :: Maybe Sex
|
||||
, audBirthday :: Maybe Day
|
||||
, audMobile :: Maybe Text
|
||||
, audTelephone :: Maybe Text
|
||||
, audFPersonalNumber :: Maybe Text
|
||||
, audFDepartment :: Maybe Text
|
||||
, audPostAddress :: Maybe StoredMarkup
|
||||
, audPrefersPostal :: Bool
|
||||
, audPinPassword :: Maybe Text
|
||||
, audEmail :: UserEmail
|
||||
, audIdent :: UserIdent
|
||||
, audAuth :: AuthenticationKind
|
||||
}
|
||||
|
||||
-- | Adds a new user to database, no background jobs are scheduled, no notifications send
|
||||
-- Note: `Foundation.Yesod.Auth` contains similar code with potentially differing defaults!
|
||||
addNewUser :: AddUserData -> Handler (Maybe UserId)
|
||||
addNewUser aud = do
|
||||
udc <- getsYesod $ view _appUserDefaults
|
||||
usr <- makeUser udc aud
|
||||
runDB $ insertUnique usr
|
||||
|
||||
-- | Variant of `addNewUser` which allows for rollback through follwing throws
|
||||
addNewUserDB :: AddUserData -> DB (Maybe UserId)
|
||||
addNewUserDB aud = do
|
||||
udc <- liftHandler $ getsYesod $ view _appUserDefaults
|
||||
usr <- makeUser udc aud
|
||||
insertUnique usr
|
||||
|
||||
makeUser :: MonadIO m => UserDefaultConf -> AddUserData -> m User
|
||||
makeUser UserDefaultConf{..} AddUserData{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
return User
|
||||
{ userIdent = audIdent
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx }
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Nothing
|
||||
, userLdapPrimaryKey = audFPersonalNumber
|
||||
, userLastAuthentication = Nothing
|
||||
, userEmail = audEmail
|
||||
, userDisplayName = audDisplayName
|
||||
, userDisplayEmail = audDisplayEmail
|
||||
, userFirstName = audFirstName
|
||||
, userSurname = audSurname
|
||||
, userTitle = audTitle
|
||||
, userSex = audSex
|
||||
, userBirthday = audBirthday
|
||||
, userMobile = audMobile
|
||||
, userTelephone = audTelephone
|
||||
, userCompanyPersonalNumber = audFPersonalNumber
|
||||
, userCompanyDepartment = audFDepartment
|
||||
, userPostAddress = audPostAddress
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPrefersPostal = audPrefersPostal
|
||||
, userPinPassword = audPinPassword
|
||||
, userMatrikelnummer = audMatriculation
|
||||
, userAuthentication = mkAuthMode audAuth
|
||||
}
|
||||
|
||||
@ -1,27 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Yesod.Form.Types.Instances
|
||||
() where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
-- import Yesod.Form.Types
|
||||
|
||||
-- import Data.Default
|
||||
import Data.Binary
|
||||
|
||||
instance Default (FieldSettings site) where
|
||||
def = ""
|
||||
|
||||
deriving instance (Show a) => Show (Option a)
|
||||
|
||||
-- to memcache Option Text and Option Textarea
|
||||
deriving instance Generic (Option Text)
|
||||
deriving instance Binary (Option Text)
|
||||
|
||||
deriving newtype instance Binary Textarea
|
||||
deriving instance Generic (Option Textarea)
|
||||
deriving instance Binary (Option Textarea)
|
||||
@ -1,9 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
^{ccTable}
|
||||
@ -1,11 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Keine momentan offene Prüfung gefunden für _{MsgTableCourse} #{csh}.
|
||||
<p>
|
||||
^{mkExamCreateBtn}
|
||||
@ -1,11 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
No currently open exam found for _{MsgTableCourse} #{csh}.
|
||||
<p>
|
||||
^{mkExamCreateBtn}
|
||||
@ -1,3 +0,0 @@
|
||||
SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
|
||||
SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
@ -1,83 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Personendaten aller AVS Fahrberechtigten
|
||||
|
||||
$if numUnknownLicenceOwners > 0
|
||||
<p>
|
||||
^{modal (text2widget (tshow numUnknownLicenceOwners <> " Personen IDs")) (Right (text2widget ("AVS Personen IDs: " <> tshow unknownLicenceOwners)))} #
|
||||
mit einer Fahrberechtigung wurden im AVS gefunden, welche FRADrive unbekannt sind. #
|
||||
|
||||
Es gibt zwei Möglichkeiten zum Auflösen dieses Problems: #
|
||||
<p>
|
||||
^{btnImportUnknownWgt}^{revokeUnknownSafetyWgt}
|
||||
|
||||
$else
|
||||
<p>
|
||||
Die Personendaten aller Fahrberechtigten im AVS sind auch in FRADrive bekannt.
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Abweichende Fahrberechtigungen
|
||||
<p>
|
||||
Die folgenden Abschnitte zeigen alle Abweichungen
|
||||
zwischen dem AVS und den in FRADrive vorliegenden Fahrberechtigungen. #
|
||||
Es wird dringend empfohlen, die Fahrberechtigungen im AVS anzupassen
|
||||
und nicht umgekehrt.
|
||||
|
||||
<h3>
|
||||
Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden und Fahrberechtigung Vorfeld gültig in FRADrive
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
Fahrberechtigung Vorfeld gültig in FRADrive, fehlt aber im AVS
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)
|
||||
<p>
|
||||
^{tb0}
|
||||
|
||||
$if notNull avsLicenceSynchTimes
|
||||
<section>
|
||||
<h2>
|
||||
Automatische AVS Fahrlizenzen Sychronisation
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
Uhrzeiten Synchronisation
|
||||
<dd .deflist__dd>
|
||||
Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
|
||||
<dt .deflist__dt>
|
||||
Synchronisationslevel
|
||||
<dd .deflist__dd>
|
||||
<strong>#{avsLicenceSynchLevel}: #
|
||||
$case avsLicenceSynchLevel
|
||||
$of 1
|
||||
Nur Vorfeld-Fahrberechtigungen entziehen
|
||||
$of 2
|
||||
Vorfeld-Fahrberechtigungen entziehen und gewähren
|
||||
$of 3
|
||||
Vorfeld-Fahrberechtigungen entziehen und gewähren, #
|
||||
so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
|
||||
$of _
|
||||
Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
|
||||
$maybe reasons <- avsLicenceSynchReasonFilter
|
||||
<dt .deflist__dt>
|
||||
Ausnahmen
|
||||
<dd .deflist__dd>
|
||||
Keine automatische Synchronisation, wenn die Begründung des letzten Un-/Blocks zu diesen regulären Ausdruck passt: #{reasons}
|
||||
$maybe maxChange <- avsLicenceSynchMaxChanges
|
||||
<dt .deflist__dt>
|
||||
Maximal Änderungen
|
||||
<dd .deflist__dd>
|
||||
Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte
|
||||
@ -1,82 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Person data of all AVS drivers
|
||||
|
||||
$if numUnknownLicenceOwners > 0
|
||||
<p>
|
||||
^{modal (text2widget (tshow numUnknownLicenceOwners <> " Person IDs")) (Right (text2widget ("AVS Person IDs: " <> tshow unknownLicenceOwners)))} #
|
||||
owning a driving licence within AVS were found, which are unknown within the FRADrive database. #
|
||||
|
||||
There are two solutions to this problem: #
|
||||
<p>
|
||||
^{btnImportUnknownWgt}
|
||||
^{revokeUnknownSafetyWgt}
|
||||
|
||||
$else
|
||||
<p>
|
||||
All AVS driving licence owners are also registered with FRADrive as expected.
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Nonconforming driving licence
|
||||
<p>
|
||||
The following sections show all discrepancies
|
||||
between AVS and FRADrive with respect to driving licences. #
|
||||
It is recommended to adjust AVS driving licences and keep FRADrive as it is.
|
||||
|
||||
<h3>
|
||||
Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS and having a valid 'F' in FRADrive
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
Apron driving licence 'F' valid in FRADrive, but not in AVS
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)
|
||||
<p>
|
||||
^{tb0}
|
||||
|
||||
$if notNull avsLicenceSynchTimes
|
||||
<section>
|
||||
<h2>
|
||||
Automatic AVS licence sychronisation
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
Synchronisation times
|
||||
<dd .deflist__dd>
|
||||
Synchronize on weekdays, few minutes after each full hour: #{tshow avsLicenceSynchTimes}
|
||||
<dt .deflist__dt>
|
||||
Synchronisation level
|
||||
<dd .deflist__dd>
|
||||
<strong>#{avsLicenceSynchLevel}: #
|
||||
$case avsLicenceSynchLevel
|
||||
$of 1
|
||||
Revoke apron driving licences only
|
||||
$of 2
|
||||
Grant and revoke apron driving licences only
|
||||
$of 3
|
||||
Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
|
||||
$of _
|
||||
Grant and revoke all driving licences automatically
|
||||
$maybe reasons <- avsLicenceSynchReasonFilter
|
||||
<dt .deflist__dt>
|
||||
Exemptions
|
||||
<dd .deflist__dd>
|
||||
Do not synchronize changes where the last un-/block reason matches #{reasons}
|
||||
$maybe maxChange <- avsLicenceSynchMaxChanges
|
||||
<dt .deflist__dt>
|
||||
Max changes
|
||||
<dd .deflist__dd>
|
||||
Do not synchronize a licence level if the number of changes exceeds #{maxChange}
|
||||
@ -1,42 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgConfigInterfacesHeading}
|
||||
<div>
|
||||
<p>
|
||||
Eine Schnittstelle gilt als fehlgeschlagen, wenn die letzte Transaktion dieser Schnittstelle ein konkreten Fehler lieferte, #
|
||||
oder wenn seit einer gewissen Zugriffsfrist kein erneuter Erfolg für diese Schnittstelle registriert wurde. #
|
||||
<p>
|
||||
Diese Zeitspanne beträgt normalerweise: #{defWarnTime} #
|
||||
<p>
|
||||
Mit der nachfolgend gezeigten Tabelle kann diese Zugriffsfrist zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund #
|
||||
des Ausbleibens eines erneuten Erfolges für einzelne Schnittstellen geändert werden. #
|
||||
Einträge mit unspezifiertem _{MsgInterfaceSubtype} und/oder _{MsgInterfaceWrite} betreffen alle drauf passenden Schnittstellen, #
|
||||
sofern es keine anderen passenden, besser spezifizierten Einträge gibt. #
|
||||
<p>
|
||||
Die Zeitspanne ist hier immer in Stunden anzugeben. #
|
||||
Eine negative Stundenzahl deaktiviert den Warnungsmechanismus für ausbleibende wiederholte Erfolge; #
|
||||
in diesem Fall werden für die Schnittstelle nur tatsächliche Fehlschläge als Fehler gemeldet. #
|
||||
Eine negative Zeitspanne von -100 oder weniger deaktiviert alle Warnungen für diese Schnittstelle.
|
||||
<p>
|
||||
^{configTable}
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgMenuInterfaces}
|
||||
<div>
|
||||
<p>
|
||||
Current interface health is shown here for reference
|
||||
<p>
|
||||
$if interfacesBadNr > 0
|
||||
_{MsgInterfacesFail interfacesBadNr}
|
||||
$else
|
||||
_{MsgInterfacesOk}
|
||||
^{interfaceTable}
|
||||
|
||||
|
||||
@ -1,38 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgConfigInterfacesHeading}
|
||||
<div>
|
||||
<p>
|
||||
An interface is flagged as failed, if an error is reported or if no new success had been reported within
|
||||
its maximum usage period, usually #{defWarnTime} #
|
||||
<p>
|
||||
The following table allows to change the time span between the last success and before an error is raised. #
|
||||
A time value having _{MsgInterfaceSubtype} and/or _{MsgInterfaceWrite} left unspecified affects all matching interfeaces, #
|
||||
unless another more specified matching row exists for a particular interface. #
|
||||
<p>
|
||||
The time span is configure by a number of hours. #
|
||||
A negative hour value disables the raising of an error by time entirely; in this case, an error is only raised if the last interface transaction reported failure. #
|
||||
A negative value of less than -100 disables all warnings for this interface.
|
||||
<p>
|
||||
^{configTable}
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgMenuInterfaces}
|
||||
<div>
|
||||
<p>
|
||||
Current interface health is shown here for reference
|
||||
<p>
|
||||
$if interfacesBadNr > 0
|
||||
_{MsgInterfacesFail interfacesBadNr}
|
||||
$else
|
||||
_{MsgInterfacesOk}
|
||||
^{interfaceTable}
|
||||
|
||||
|
||||
@ -1,32 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
$maybe tbl <- tableDaily
|
||||
<section>
|
||||
<p>
|
||||
^{tbl}
|
||||
<p>
|
||||
^{consistencyBtn}
|
||||
<section .profile>
|
||||
<h3>Hinweise zu den Formularspalten
|
||||
<dl .deflist.profile-dl>
|
||||
<dt .deflist__dt>
|
||||
_{MsgTutorialDrivingPermit}, _{MsgTutorialEyeExam}, _{MsgTutorialNote}
|
||||
<dd .deflist__dd>
|
||||
Pro Kurs und Teilnehmer wird je ein Wert gespeichert.
|
||||
<dt .deflist__dt>
|
||||
_{MsgTutorialDayAttendance mempty}, _{MsgTutorialDayNote mempty}
|
||||
<dd .deflist__dd>
|
||||
Pro Tag, Kurs und Teilnehmer wird je ein Wert gespeichert.
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableUserParkingToken mempty}
|
||||
<dd .deflist__dd>
|
||||
Pro Tag und Teilnehmer wird ein Wert gespeichert, d.h. unabhängig vom Kurs.
|
||||
\ Daraus folgt, dass die Parkmarke immer in allen Zeilen des gleichen Teilnehmers geändert werden muss.
|
||||
$nothing
|
||||
<section>
|
||||
An diesem Tag sind zur Zeit keine Kurse eingetragen.
|
||||
|
||||
@ -1,32 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
$maybe tbl <- tableDaily
|
||||
<section>
|
||||
<p>
|
||||
^{tbl}
|
||||
<p>
|
||||
^{consistencyBtn}
|
||||
<section .profile>
|
||||
<h3>Note how form data is saved
|
||||
<dl .deflist.profile-dl>
|
||||
<dt .deflist__dt>
|
||||
_{MsgTutorialDrivingPermit}, _{MsgTutorialEyeExam}, _{MsgTutorialNote}
|
||||
<dd .deflist__dd>
|
||||
For each course and participant pairing, one value is stored each.
|
||||
<dt .deflist__dt>
|
||||
_{MsgTutorialDayAttendance mempty}, _{MsgTutorialDayNote mempty}
|
||||
<dd .deflist__dd>
|
||||
For each day, course and participant, one value is stored each.
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableUserParkingToken mempty}
|
||||
<dd .deflist__dd>
|
||||
For each day and participant, one value is stored, i.e., indipendant of the course.
|
||||
\ This requires that a change is performed in all rows of the same participant.
|
||||
$nothing
|
||||
<section>
|
||||
No courses are currently scheduled on this day.
|
||||
|
||||
@ -1,26 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
|
||||
|
||||
<p>
|
||||
Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist #
|
||||
und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, #
|
||||
dass <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird. #
|
||||
Dies kann hier mit der Aktion "Firmenansprechpartner entfernen" nicht geändert werden, #
|
||||
da die Ansprechpartnerbeziehung ja über eine andere Firma weiter existiert.
|
||||
|
||||
^{firmContactInfo}
|
||||
|
||||
^{formFirmAction}
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgTableSupervisor}
|
||||
<div>
|
||||
^{fsprTable}
|
||||
@ -1,24 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Note that supervisionship is company independent! #
|
||||
<p>
|
||||
For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, #
|
||||
then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>. #
|
||||
This cannot be changed through action "Remove default supervisor" here, since the external supervisionship persists.
|
||||
|
||||
^{firmContactInfo}
|
||||
|
||||
^{formFirmAction}
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgTableSupervisor}
|
||||
<div>
|
||||
^{fsprTable}
|
||||
|
||||
@ -1,33 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Gezeigt werden E‑Learning Logins, welche für Qualifikation #{qsh} an FRADrive zurückgemeldet wurden #
|
||||
und von FRADrive nicht mehr zugeordnet werden können. #
|
||||
|
||||
Normalerweise löscht das LMS beendete E‑Learning Logins selbstständig. #
|
||||
In manchen Fällen passiert dies aus unbekanntem Grund jedoch nicht. #
|
||||
Wenn jedoch ein Grund bekannt sein sollte, wie zum Beispiel ein manueller Neustart des E‑Learnings, #
|
||||
wird dieser in Spalte "_{MsgLmsOrphanReason}" angezeigt. #
|
||||
|
||||
<p>
|
||||
Verwaiste Logins werden beim nächsten Abruf der E‑Learning Logins von FRADrive zur Löschung durch das LMS gemeldet. #
|
||||
Die Auswahl, ob ein E‑Learning Login zur Löschung gemeldet wird, hängt von folgenden Kriterien ab: #
|
||||
<ul>
|
||||
<li>"_{MsgLmsOrphanSeenFirst}" liegt mindestens #{lmsOrphanDeletionDays} Tage zurück.
|
||||
<li>"_{MsgLmsOrphanSeenLast}" liegt höchstens #{lmsOrphanRepeatHours} Stunden zurück.
|
||||
<li>"_{MsgLmsOrphanDeletedLast}", d.h. der letzte Löschantrag für diesen Login ist älter als #{lmsOrphanRepeatHours} Stunden #
|
||||
oder wurde noch gar nicht gestellt.
|
||||
<li>Der E‑Learning Login ist auch unter keiner anderen Qualifikation in FRADrive bekannt.
|
||||
<p>
|
||||
Es werden jedoch pro Abruf nur #{lmsOrphanDeletionBatch} E‑Learning Logins zur Löschung an das LMS gemeldet. #
|
||||
Dabei werden Logins bevorzugt welche noch gar nicht oder vor der längsten Zeit gemeldet wurden ("_{MsgLmsOrphanDeletedLast}"), #
|
||||
sollte davon es jeweils mehrere Kandidaten geben, dann werden diejenigen ausgewählt, welche kürzlich zurückgemeldet wurden ("_{MsgLmsOrphanSeenLast}").
|
||||
|
||||
<section>
|
||||
<p>
|
||||
^{orvTable}
|
||||
@ -1,33 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Displayed are e‑learning logins that have been reported back to FRADrive for qualification #{qsh}, #
|
||||
but which are unknown to FRADrive. #
|
||||
|
||||
Normally, the LMS automatically deletes completed e‑learning logins. #
|
||||
In some cases, however, this does not happen for unknown reasons. #
|
||||
If a reason is known, such as a manual restart of the e‑learning, #
|
||||
this is shown in the column "_{MsgLmsOrphanReason}". #
|
||||
|
||||
<p>
|
||||
Orphaned logins will be reported for deletion by FRADrive to the LMS during the next retrieval of e‑learning logins. #
|
||||
The decision whether an e‑learning login is reported for deletion depends on the following criteria: #
|
||||
<ul>
|
||||
<li>"_{MsgLmsOrphanSeenFirst}" is at least #{lmsOrphanDeletionDays} days ago.
|
||||
<li>"_{MsgLmsOrphanSeenLast}" is at most #{lmsOrphanRepeatHours} hours ago.
|
||||
<li>"_{MsgLmsOrphanDeletedLast}", i.e., the last deletion request for this login is older than #{lmsOrphanRepeatHours} hours #
|
||||
or has not been made yet.
|
||||
<li>The e‑learning login is not associated with any other qualification within FRADrive.
|
||||
<p>
|
||||
However, only #{lmsOrphanDeletionBatch} e‑learning logins are reported for deletion to the LMS per request. #
|
||||
Logins that have not yet been reported for deletion at all or were reported the longest time ago ("_{MsgLmsOrphanDeletedLast}") are preferred, #
|
||||
if there are multiple candidates, those that were most recently reported back ("_{MsgLmsOrphanSeenLast}") will be selected.
|
||||
|
||||
<section>
|
||||
<p>
|
||||
^{orvTable}
|
||||
@ -1,46 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2025 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Benachrichtigungen für ^{usrWgt} ^{widgetMailPrefPin usr} #
|
||||
$if usrReceives
|
||||
gehen #
|
||||
$maybe _ <- mrtbl
|
||||
ebenfalls an die unten aufgeführten Personen:
|
||||
$nothing
|
||||
nur an diese Person selbst.
|
||||
$else
|
||||
$maybe _ <- mrtbl
|
||||
gehen tatsächlich nur an die unten aufgeführten Personen:
|
||||
$nothing
|
||||
werden momentan an niemanden zugestellt!
|
||||
$maybe (tbl, mbUsrCmps) <- mrtbl
|
||||
<p>
|
||||
^{tbl}
|
||||
<p>
|
||||
$maybe usrCmps <- mbUsrCmps
|
||||
<h4>
|
||||
_{MsgCompany} ^{usrWgt}:
|
||||
<ul .list--inline .list--comma-separated>
|
||||
^{usrCmps}
|
||||
$nothing
|
||||
Für ^{usrWgt} ist momentan keine Firmenzugehörigkeit bekannt.
|
||||
<p>
|
||||
<h4>
|
||||
Hinweis:
|
||||
Mit welchem Passwort PDF Anhänge geschützt werden, hängt vom Nachrichtentyp ab. #
|
||||
|
||||
Zum Beispiel werden Pin Briefe für ablaufende Qualifikationen #
|
||||
$if hasPwd
|
||||
mit dem Passwort von ^{usrWgt} geschützt. #
|
||||
$else
|
||||
nicht geschützt, da kein Pin Passwort gesetzt ist. #
|
||||
|
||||
Für andere Benachrichtigungen wird meist das Passwort des tatsächlichen Empfängers gewählt, sofern eins gesetzt wurde.
|
||||
|
||||
Die Voreinstellung für das PDF Passwort ist die Hauptausweisnummer, inklusive Punkt.
|
||||
@ -1,44 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2025 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Notifications for ^{usrWgt} ^{widgetMailPrefPin usr} #
|
||||
$if usrReceives
|
||||
$maybe _ <- mrtbl
|
||||
are also sent additionally to the following persons:
|
||||
$nothing
|
||||
are received only by them.
|
||||
$else
|
||||
$maybe _ <- mrtbl
|
||||
are only sent to the following persons instead:
|
||||
$nothing
|
||||
are currently not delivered to anyone!
|
||||
$maybe (tbl, mbUsrCmps) <- mrtbl
|
||||
<p>
|
||||
^{tbl}
|
||||
<p>
|
||||
$maybe usrCmps <- mbUsrCmps
|
||||
<h4>
|
||||
_{MsgCompany} ^{usrWgt}:
|
||||
<ul .list--inline .list--comma-separated>
|
||||
^{usrCmps}
|
||||
$nothing
|
||||
^{usrWgt} is currently not affiliated with any company.
|
||||
<p>
|
||||
<h4>
|
||||
Note:
|
||||
The password used to protect PDF attachments depends on the message type. #
|
||||
For example, pin letters for expiring qualifications #
|
||||
$if hasPwd
|
||||
are protected by the password of ^{usrWgt}. #
|
||||
$else
|
||||
are not protected, since ^{usrWgt} has no Pin password set. #
|
||||
|
||||
For other notifications, the password of the actual recipient is usually chosen, if a password has been set.
|
||||
|
||||
The default PDF password is their main ID card number, including the period.
|
||||
@ -1,3 +0,0 @@
|
||||
SPDX-FileCopyrightText: 2023-24 Steffen Jost <S.Jost@Fraport.de>
|
||||
|
||||
SPDX-License-Identifier: LicenseRef-Fraport-Corporate-Design
|
||||
@ -1,159 +0,0 @@
|
||||
---
|
||||
### Metadaten, welche hier eingestellt werden:
|
||||
# Absender
|
||||
author: Fraport AG - Fahrerausbildung (AVN-AR)
|
||||
phone: +49 69 690-30306
|
||||
email: fahrerausbildung@fraport.de
|
||||
place: Frankfurt am Main
|
||||
return-address:
|
||||
- 60547 Frankfurt
|
||||
de-opening: Guten Tag,
|
||||
en-opening: Dear driver,
|
||||
de-closing: |
|
||||
Mit freundlichen Grüßen
|
||||
\vspace{2EX}
|
||||
Fraport Fahrerausbildung
|
||||
en-closing: |
|
||||
With kind regards
|
||||
\vspace{2EX}
|
||||
Fraport Driver Training
|
||||
encludes:
|
||||
hyperrefoptions: colorlinks=false
|
||||
|
||||
### Metadaten, welche automatisch ersetzt werden:
|
||||
de-subject: 'Verlängerung Fahrberechtigung "F" (Vorfeldführerschein)'
|
||||
en-subject: Renewal of apron driving license
|
||||
qarea: 'Vorfeld'
|
||||
qformal: 'Fahrberechtigung'
|
||||
qlicence: 'Führerschein'
|
||||
url-text: 'drive.fraport.de'
|
||||
url: 'https://drive.fraport.de'
|
||||
date: 11.11.1111
|
||||
expiry: 00.00.0000
|
||||
lang: de-DE
|
||||
is-de: true
|
||||
login: 123456
|
||||
pin: abcdef
|
||||
paper: pin
|
||||
# Emfpänger
|
||||
examinee: P. Rüfling
|
||||
address:
|
||||
- E. M. Pfänger
|
||||
- Musterfirma GmbH
|
||||
- Musterstraße 11
|
||||
- 12345 Musterstadt
|
||||
...
|
||||
$if(titleblock)$
|
||||
$titleblock$
|
||||
|
||||
$endif$
|
||||
$for(header-includes)$
|
||||
$header-includes$
|
||||
|
||||
$endfor$
|
||||
$for(include-before)$
|
||||
$include-before$
|
||||
|
||||
$endfor$
|
||||
|
||||
$if(is-de)$
|
||||
|
||||
<!-- deutsche Version des Briefes -->
|
||||
|
||||
$if(reminder)$
|
||||
dies ist die **letzte Erinnerung**: Bis $date$ wurde das E-Learning noch nicht abgeschlossen. Um
|
||||
$else$
|
||||
um
|
||||
$endif$
|
||||
$if(supervisor)$
|
||||
die $qformal$ von **$examinee$**
|
||||
$else$
|
||||
Ihre $qformal$
|
||||
$endif$
|
||||
zu verlängern, benötigen wir bis zum **$expiry$** den Nachweis,
|
||||
dass die
|
||||
$if(practical)$
|
||||
theoretische und praktische
|
||||
$endif$
|
||||
flughafenspezifische $qarea$ Recurrent Schulung
|
||||
der Fraport AG gemäß Verordnung der Europäische Union Nr. 139/2014 absolviert wurde.
|
||||
|
||||
Die Online-Schulung der Fraport AG ist erreichbar unter folgendem Link:
|
||||
[$url-text$]($url$)
|
||||
|
||||
Benutzername und Passwort für die Fraport Online-Schulung finden Sie untenstehend.
|
||||
Die Weitergabe der persönlichen Benutzerdaten an Dritte ist untersagt.
|
||||
$if(supervisor)$
|
||||
Ausschließlich Sie sind berechtigt, die Benutzerdaten an den Schulungsteilnehmer auszuhändigen.
|
||||
$endif$
|
||||
|
||||
Für die Absolvierung der Schulungsmaßnahme werden ca. 2 Stunden benötigt.
|
||||
Der Abschluss der Schulung wird automatisch an das System der Fraport Fahrerausbildung übermittelt.
|
||||
|
||||
$if(practical)$
|
||||
Nach erfolgreichem Abschluss der Online-Schulung
|
||||
$if(supervisor)$
|
||||
muss \textbf{$examinee$}
|
||||
$else$
|
||||
lassen Sie
|
||||
$endif$
|
||||
sich von Ihrer Firma zum praktischen Teil der Schulung
|
||||
$if(supervisor)$
|
||||
anmelden lassen.
|
||||
$else$
|
||||
anmelden.
|
||||
$endif$
|
||||
Im Rahmen der ca. 4-stündigen praktischen Auffrischung erfolgen Funkübungen
|
||||
sowie die Durchführung einer Übungsfahrt mit Prüfungscharakter
|
||||
im Start-/Landebahnsystem.
|
||||
$endif$
|
||||
|
||||
|
||||
$else$
|
||||
|
||||
|
||||
<!-- englische Version des Briefes -->
|
||||
$if(reminder)$
|
||||
this is a last **reminder**: as of $date$, the e-learning has not been completed. In
|
||||
$else$
|
||||
in
|
||||
$endif$
|
||||
order to maintain
|
||||
$if(supervisor)$
|
||||
the $qformal$ of **$examinee$**,
|
||||
$else$
|
||||
your $qformal$,
|
||||
$endif$
|
||||
we require by **$expiry$**, that the
|
||||
$if(practical)$
|
||||
theorectical and practical
|
||||
$endif$
|
||||
airport-specific $qarea$ recurrent training at Fraport AG,
|
||||
according to European Union Regulation No. 139/2014,
|
||||
has been completed.
|
||||
|
||||
The e-learning can be accessed with this link:
|
||||
[$url-text$]($url$)
|
||||
|
||||
The required username and password for this Fraport e-learning are provided below.
|
||||
Note that sharing of this personal login data with third parties is prohibited.
|
||||
$if(supervisor)$
|
||||
Only you are authorized to hand over the personal login data to the training participant.
|
||||
$endif$
|
||||
|
||||
The completion of the e-learning will require abut ca. 2 hours.
|
||||
Results will be automatically transmitted to Fraport Driver Training.
|
||||
|
||||
$if(practical)$
|
||||
After successful completion of the online training,
|
||||
$if(supervisor)$
|
||||
$examinee$ must be scheduled by your company
|
||||
$else$
|
||||
your company must schedule you
|
||||
$endif$
|
||||
for the practical part of the training.
|
||||
The ca. 4 hour practical refresher includes radio exercises and
|
||||
an examination-style test drive within the runway system.
|
||||
$endif$
|
||||
|
||||
$endif$
|
||||
@ -1,9 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
^{mcTable}
|
||||
@ -1,10 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<ul .list--iconless .list--inline .list--comma-separated>
|
||||
$forall (attrs, widget) <- cells
|
||||
<li *{attrs}>
|
||||
^{widget}
|
||||
@ -1,29 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>_{MsgTableTutorialOccurrence}
|
||||
<dd .deflist__dd>
|
||||
^{occurrencesWidget tutorialRoomHidden tutorialTime}
|
||||
<dt .deflist__dt>_{MsgTableTutorialTutors}
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
$forall (Entity _ usr) <- tutors
|
||||
<li>
|
||||
^{userEmailWidget usr}
|
||||
<section>
|
||||
^{participantTable}
|
||||
<section>
|
||||
$# <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
||||
<h2>
|
||||
_{MsgExamFormOccurrences}
|
||||
<div>
|
||||
<p>
|
||||
$if hasExams
|
||||
^{gtaForm}
|
||||
$else
|
||||
^{mkExamCreateBtn}
|
||||
@ -1,11 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
$if not (null lessons)
|
||||
<ul .list--iconless>
|
||||
$forall lsn <- lessons
|
||||
<li>
|
||||
^{lsn}
|
||||
@ -1,9 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 20 24 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
#{lStart}–#{lEnd}
|
||||
$if not roomHidden
|
||||
\ ^{foldMap roomReferenceWidget lessonRoom}
|
||||
@ -1,9 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
^{formView}
|
||||
<td .table__td>
|
||||
^{fvWidget submitView}
|
||||
@ -1,11 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<td .table__td>
|
||||
#{csrf}
|
||||
^{fvWidget cquView}
|
||||
<td .table__td>
|
||||
^{fvWidget ordView}
|
||||
@ -1,21 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<table .table .table--striped .table--hover>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
<th .table__th>_{MsgTableQualification}
|
||||
<th .table__th>_{MsgSortPriority}
|
||||
<td>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell .table__row>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvWidget (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
@ -1,11 +0,0 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
_{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'}
|
||||
$if roomHidden
|
||||
_{MsgTableTutorialRoomIsHidden}
|
||||
$else
|
||||
^{foldMap roomReferenceWidget scheduleRoom}
|
||||
7
cbt.sh
Executable file
7
cbt.sh
Executable file
@ -0,0 +1,7 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
cbt_tunnels --username $CBT_USERNAME --authkey $CBT_AUTHKEY
|
||||
@ -2,4 +2,4 @@
|
||||
//
|
||||
// SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module.exports = {extends: ['@commitlint/config-conventional']};
|
||||
module.exports = {extends: ['@commitlint/config-conventional']}
|
||||
|
||||
89
compose.yaml
89
compose.yaml
@ -1,86 +1,35 @@
|
||||
services:
|
||||
help:
|
||||
image: docker.io/library/perl:stable
|
||||
pull_policy: if_not_present
|
||||
volumes:
|
||||
- ./utils/makehelp.pl:/mnt/utils/makehelp.pl:ro
|
||||
- ./Makefile:/tmp/Makefile:ro
|
||||
command: /mnt/utils/makehelp.pl /tmp/Makefile
|
||||
|
||||
frontend:
|
||||
# image: registry.uniworx.de/fradrive/fradrive/frontend # TODO: reference to current branch required; how to do that here?
|
||||
# pull_policy: if_not_present
|
||||
build:
|
||||
context: ./frontend
|
||||
dockerfile: ./Dockerfile
|
||||
dockerfile: ./docker/frontend/Dockerfile
|
||||
context: .
|
||||
environment:
|
||||
- PROJECT_DIR=/fradrive
|
||||
volumes:
|
||||
- type: bind
|
||||
source: ./frontend
|
||||
target: /fradrive
|
||||
- ./assets:/fradrive/assets:rw
|
||||
- ./static:/fradrive/static:rw
|
||||
- ./well-known:/fradrive/well-known:rw
|
||||
|
||||
- &fradrive-mnt .:/tmp/fradrive
|
||||
backend:
|
||||
# image: registry.uniworx.de/fradrive/fradrive/backend
|
||||
# pull_policy: if_not_present
|
||||
build:
|
||||
context: ./backend
|
||||
dockerfile: ./Dockerfile
|
||||
environment:
|
||||
PATH: /fradrive/bin:$PATH
|
||||
dockerfile: ./docker/backend/Dockerfile
|
||||
context: ./
|
||||
volumes:
|
||||
- ./backend:/fradrive
|
||||
- ./bin:/fradrive/bin
|
||||
- ./assets:/fradrive/assets:ro
|
||||
- ./static:/fradrive/static:ro
|
||||
- ./well-known:/fradrive/well-known:ro
|
||||
- *fradrive-mnt
|
||||
depends_on:
|
||||
- frontend
|
||||
- postgres
|
||||
- memcached
|
||||
- minio
|
||||
- maildev
|
||||
ports:
|
||||
- "3000:3000" # dev http
|
||||
- "3443:3443" # dev https
|
||||
- "8081:8081" # hoogle
|
||||
# links:
|
||||
# - postgres
|
||||
# - memcached
|
||||
# - minio
|
||||
# - maildev
|
||||
stdin_open: true
|
||||
network_mode: host
|
||||
|
||||
postgres:
|
||||
image: docker.io/library/postgres:12
|
||||
pull_policy: if_not_present
|
||||
database:
|
||||
# image: registry.uniworx.de/fradrive/fradrive/database
|
||||
# pull_policy: if_not_present
|
||||
build: ./docker/database
|
||||
ports:
|
||||
- "5432:5432"
|
||||
environment:
|
||||
- POSTGRES_HOST_AUTH_METHOD=trust
|
||||
volumes:
|
||||
- ./docker/postgres/pg_hba.conf:/tmp/pg_hba.conf:ro
|
||||
- ./docker/postgres/postgresql.conf:/tmp/postgresql.conf:ro
|
||||
- ./docker/postgres/pgconfig.sh:/docker-entrypoint-initdb.d/_pgconfig.sh:ro
|
||||
- ./docker/postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
|
||||
- "9876:5432"
|
||||
# privileged: true
|
||||
|
||||
memcached:
|
||||
image: docker.io/library/memcached:latest
|
||||
pull_policy: if_not_present
|
||||
ports:
|
||||
- "11211:11211"
|
||||
|
||||
minio:
|
||||
image: docker.io/minio/minio:latest
|
||||
pull_policy: if_not_present
|
||||
command: server `mktemp`
|
||||
ports:
|
||||
- "9000:9000"
|
||||
|
||||
maildev:
|
||||
image: docker.io/maildev/maildev:latest
|
||||
pull_policy: if_not_present
|
||||
ports:
|
||||
- "1025-1026:1025"
|
||||
# driver: local
|
||||
# driver_opts:
|
||||
# type: none
|
||||
# o: bind
|
||||
# device: ./
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -83,7 +83,6 @@ health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER
|
||||
|
||||
synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600" # 14 Tage in Sekunden
|
||||
synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600" # jede Stunde
|
||||
synchronise-ldap-users-expire: "_env:SYNCHRONISE_LDAP_EXPIRE:15897600" # halbes Jahr in Sekunden
|
||||
|
||||
synchronise-avs-users-within: "_env:SYNCHRONISE_AVS_WITHIN:5702400" # alle 66 Tage
|
||||
synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 Stunden
|
||||
@ -91,6 +90,10 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6
|
||||
study-features-recache-relevance-within: 172800
|
||||
study-features-recache-relevance-interval: 293
|
||||
|
||||
# Enqueue at specified hour, a few minutes later
|
||||
# job-lms-qualifications-enqueue-hour: 15
|
||||
# job-lms-qualifications-dequeue-hour: 3
|
||||
|
||||
log-settings:
|
||||
detailed: "_env:DETAILED_LOGGING:false"
|
||||
all: "_env:LOG_ALL:false"
|
||||
@ -146,22 +149,18 @@ ldap:
|
||||
ldap-re-test-failover: 60
|
||||
|
||||
lms-direct:
|
||||
upload-header: "_env:LMSUPLOADHEADER:true"
|
||||
upload-delimiter: "_env:LMSUPLOADDELIMITER:"
|
||||
download-header: "_env:LMSDOWNLOADHEADER:true"
|
||||
download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
|
||||
download-cr-lf: "_env:LMSDOWNLOADCRLF:true"
|
||||
orphan-deletion-days: "_env:LMSORPHANDELETIONDAYS:33"
|
||||
orphan-deletion-batch: "_env:LMSORPHANDELETIONBATCH:12"
|
||||
orphan-deletion-repeat-hours: "_env:LMSORPHANDELETIONREPEATHOURS:24"
|
||||
upload-header: "_env:LMSUPLOADHEADER:true"
|
||||
upload-delimiter: "_env:LMSUPLOADDELIMITER:"
|
||||
download-header: "_env:LMSDOWNLOADHEADER:true"
|
||||
download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
|
||||
download-cr-lf: "_env:LMSDOWNLOADCRLF:true"
|
||||
deletion-days: "_env:LMSDELETIONDAYS:7"
|
||||
|
||||
avs:
|
||||
host: "_env:AVSHOST:skytest.fra.fraport.de"
|
||||
port: "_env:AVSPORT:443"
|
||||
user: "_env:AVSUSER:fradrive"
|
||||
pass: "_env:AVSPASS:\"0000\""
|
||||
timeout: "_env:AVSTIMEOUT:42"
|
||||
cache-expiry: "_env:AVSCACHEEXPIRY:420"
|
||||
host: "_env:AVSHOST:skytest.fra.fraport.de"
|
||||
port: "_env:AVSPORT:443"
|
||||
user: "_env:AVSUSER:fradrive"
|
||||
pass: "_env:AVSPASS:"
|
||||
|
||||
lpr:
|
||||
host: "_env:LPRHOST:fravm017173.fra.fraport.de"
|
||||
@ -208,6 +207,9 @@ memcached:
|
||||
timeout: "_env:MEMCACHED_TIMEOUT:20"
|
||||
expiration: "_env:MEMCACHED_EXPIRATION:300"
|
||||
memcache-auth: true
|
||||
memcached-local:
|
||||
maximum-ghost: 512
|
||||
maximum-weight: 104857600 # 100MiB
|
||||
|
||||
upload-cache:
|
||||
host: "_env:UPLOAD_S3_HOST:localhost" # should be optional, but all file transfers will be empty without an S3 cache
|
||||
@ -276,8 +278,8 @@ user-defaults:
|
||||
max-favourites: 0
|
||||
max-favourite-terms: 2
|
||||
theme: Default
|
||||
date-time-format: "%d.%m.%Y %R"
|
||||
date-format: "%d.%m.%y"
|
||||
date-time-format: "%d %b %y %R"
|
||||
date-format: "%d %b %Y"
|
||||
time-format: "%R"
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
@ -319,6 +321,17 @@ fallback-personalised-sheet-files-keys-expire: 2419200
|
||||
|
||||
download-token-expire: 604801
|
||||
|
||||
file-source-arc:
|
||||
maximum-ghost: 512
|
||||
maximum-weight: 1073741824 # 1GiB
|
||||
file-source-prewarm:
|
||||
maximum-weight: 1073741824 # 1GiB
|
||||
start: 1800 # 30m
|
||||
end: 600 # 10m
|
||||
inhibit: 3600 # 60m
|
||||
steps: 20
|
||||
max-speedup: 3
|
||||
|
||||
bot-mitigations:
|
||||
- only-logged-in-table-sorting
|
||||
- unauthorized-form-honeypots
|
||||
@ -16,4 +16,5 @@ log-settings:
|
||||
auth-dummy-login: true
|
||||
server-session-acid-fallback: true
|
||||
|
||||
job-workers: 20
|
||||
job-cron-interval: null
|
||||
job-workers: 1
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user