Compare commits

..

8 Commits

1340 changed files with 28658 additions and 37291 deletions

View File

@ -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 }}'

View File

@ -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.)

View File

@ -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

View File

@ -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'

View File

@ -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)'

View File

@ -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}}'

View File

@ -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
View 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
View 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
View File

@ -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

View File

@ -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

View File

@ -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}}'
};

View File

@ -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
View File

@ -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

View File

@ -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
View 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

View File

@ -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}

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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")

View File

@ -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}
|]

View File

@ -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")

View File

@ -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

View File

@ -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}
|]

View File

@ -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{..}

View File

@ -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}
|]

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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
}
))

View File

@ -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"
}
-}

View File

@ -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}
|]

View File

@ -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
```

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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 = ' '

View File

@ -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

View File

@ -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

View File

@ -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])
}

View File

@ -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
}

View File

@ -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)

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -1,3 +0,0 @@
SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
SPDX-License-Identifier: AGPL-3.0-or-later

View File

@ -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

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -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.

View File

@ -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.

View File

@ -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}

View File

@ -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}

View File

@ -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 ELearning 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 ELearning 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 ELearnings, #
wird dieser in Spalte "_{MsgLmsOrphanReason}" angezeigt. #
<p>
Verwaiste Logins werden beim nächsten Abruf der ELearning Logins von FRADrive zur Löschung durch das LMS gemeldet. #
Die Auswahl, ob ein ELearning 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 ELearning Login ist auch unter keiner anderen Qualifikation in FRADrive bekannt.
<p>
Es werden jedoch pro Abruf nur #{lmsOrphanDeletionBatch} ELearning 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}

View File

@ -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 elearning logins that have been reported back to FRADrive for qualification #{qsh}, #
but which are unknown to FRADrive. #
Normally, the LMS automatically deletes completed elearning logins. #
In some cases, however, this does not happen for unknown reasons. #
If a reason is known, such as a manual restart of the elearning, #
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 elearning logins. #
The decision whether an elearning 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 elearning login is not associated with any other qualification within FRADrive.
<p>
However, only #{lmsOrphanDeletionBatch} elearning 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}

View File

@ -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.

View File

@ -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.

View File

@ -1,3 +0,0 @@
SPDX-FileCopyrightText: 2023-24 Steffen Jost <S.Jost@Fraport.de>
SPDX-License-Identifier: LicenseRef-Fraport-Corporate-Design

View File

@ -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$

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -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}

View File

@ -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)}

View File

@ -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
View 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

View File

@ -2,4 +2,4 @@
//
// SPDX-License-Identifier: AGPL-3.0-or-later
module.exports = {extends: ['@commitlint/config-conventional']};
module.exports = {extends: ['@commitlint/config-conventional']}

View File

@ -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: ./

View File

@ -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

View File

@ -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