Merge branch 'master' into mobile-fixes
This commit is contained in:
Gregor Kleen
commit
5176352a5e
10
ChangeLog.md
10
ChangeLog.md
@ -1,3 +1,13 @@
|
||||
* Version 13.05.2019
|
||||
|
||||
Kursverwalter können Teilnehmer hinzufügen
|
||||
|
||||
* Version 10.05.2019
|
||||
|
||||
Besseres Interface zum Einstellen von Abgebenden
|
||||
|
||||
Download von allen Dateien pro Kursmaterial/Übungsblatt
|
||||
|
||||
* Version 04.05.2019
|
||||
|
||||
Kursmaterial
|
||||
|
||||
788
config/mimetypes
Normal file
788
config/mimetypes
Normal file
@ -0,0 +1,788 @@
|
||||
# Mapping of mime-types to file extensions
|
||||
#
|
||||
# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’
|
||||
#
|
||||
# Format is a single mime-type per line (may not contain whitespace) followed by a whitespace separated list of zero or more file extension (without leading ‘.’)
|
||||
# Any file extension may occur at most once within this file
|
||||
#
|
||||
# Extensions are compared case-insensitive (see `Data.Text.toLower`)
|
||||
|
||||
application/andrew-inset ez
|
||||
application/applixware aw
|
||||
application/atom+xml atom
|
||||
application/atomcat+xml atomcat
|
||||
application/atomsvc+xml atomsvc
|
||||
application/ccxml+xml ccxml
|
||||
application/cdmi-capability cdmia
|
||||
application/cdmi-container cdmic
|
||||
application/cdmi-domain cdmid
|
||||
application/cdmi-object cdmio
|
||||
application/cdmi-queue cdmiq
|
||||
application/cu-seeme cu
|
||||
application/davmount+xml davmount
|
||||
application/docbook+xml dbk
|
||||
application/dssc+der dssc
|
||||
application/dssc+xml xdssc
|
||||
application/ecmascript ecma
|
||||
application/emma+xml emma
|
||||
application/epub+zip epub
|
||||
application/exi exi
|
||||
application/font-tdpfr pfr
|
||||
application/font-woff woff
|
||||
application/font-woff2 woff2
|
||||
application/futuresplash spl
|
||||
application/gml+xml gml
|
||||
application/gpx+xml gpx
|
||||
application/gxf gxf
|
||||
application/hyperstudio stk
|
||||
application/inkml+xml inkml ink
|
||||
application/ipfix ipfix
|
||||
application/java-archive war jar ear
|
||||
application/java-serialized-object ser
|
||||
application/java-vm class
|
||||
application/javascript js
|
||||
application/json json
|
||||
application/jsonml+json jsonml
|
||||
application/lost+xml lostxml
|
||||
application/mac-binhex40 hqx
|
||||
application/mac-compactpro cpt
|
||||
application/mads+xml mads
|
||||
application/marc mrc
|
||||
application/marcxml+xml mrcx
|
||||
application/mathematica nb mb ma
|
||||
application/mathml+xml mathml
|
||||
application/mbox mbox
|
||||
application/mediaservercontrol+xml mscml
|
||||
application/metalink+xml metalink
|
||||
application/metalink4+xml meta4
|
||||
application/mets+xml mets
|
||||
application/mods+xml mods
|
||||
application/mp21 mp21 m21
|
||||
application/mp4 mp4s
|
||||
application/msword dot doc
|
||||
application/mxf mxf
|
||||
application/octet-stream so pkg msp msm mar lrf img elc dump dms distz dist deploy bpk bin
|
||||
application/oda oda
|
||||
application/oebps-package+xml opf
|
||||
application/ogg ogx
|
||||
application/omdoc+xml omdoc
|
||||
application/onenote onetoc2 onetoc onetmp onepkg
|
||||
application/oxps oxps
|
||||
application/patch-ops-error+xml xer
|
||||
application/pdf pdf
|
||||
application/pgp-encrypted pgp
|
||||
application/pgp-signature sig
|
||||
application/pics-rules prf
|
||||
application/pkcs10 p10
|
||||
application/pkcs7-mime p7m p7c
|
||||
application/pkcs7-signature p7s
|
||||
application/pkcs8 p8
|
||||
application/pkix-attr-cert ac
|
||||
application/pkix-cert cer
|
||||
application/pkix-crl crl
|
||||
application/pkix-pkipath pkipath
|
||||
application/pkixcmp pki
|
||||
application/pls+xml pls
|
||||
application/postscript ps eps ai
|
||||
application/prs.cww cww
|
||||
application/pskc+xml pskcxml
|
||||
application/rdf+xml rdf
|
||||
application/reginfo+xml rif
|
||||
application/relax-ng-compact-syntax rnc
|
||||
application/resource-lists+xml rl
|
||||
application/resource-lists-diff+xml rld
|
||||
application/rls-services+xml rs
|
||||
application/rpki-ghostbusters gbr
|
||||
application/rpki-manifest mft
|
||||
application/rpki-roa roa
|
||||
application/rsd+xml rsd
|
||||
application/rss+xml rss
|
||||
application/rtf rtf
|
||||
application/sbml+xml sbml
|
||||
application/scvp-cv-request scq
|
||||
application/scvp-cv-response scs
|
||||
application/scvp-vp-request spq
|
||||
application/scvp-vp-response spp
|
||||
application/sdp sdp
|
||||
application/set-payment-initiation setpay
|
||||
application/set-registration-initiation setreg
|
||||
application/shf+xml shf
|
||||
application/smil+xml smil smi
|
||||
application/sparql-query rq
|
||||
application/sparql-results+xml srx
|
||||
application/srgs gram
|
||||
application/srgs+xml grxml
|
||||
application/sru+xml sru
|
||||
application/ssdl+xml ssdl
|
||||
application/ssml+xml ssml
|
||||
application/tei+xml teicorpus tei
|
||||
application/thraud+xml tfi
|
||||
application/timestamped-data tsd
|
||||
application/vnd.3gpp.pic-bw-large plb
|
||||
application/vnd.3gpp.pic-bw-small psb
|
||||
application/vnd.3gpp.pic-bw-var pvb
|
||||
application/vnd.3gpp2.tcap tcap
|
||||
application/vnd.3m.post-it-notes pwn
|
||||
application/vnd.accpac.simply.aso aso
|
||||
application/vnd.accpac.simply.imp imp
|
||||
application/vnd.acucobol acu
|
||||
application/vnd.acucorp atc acutc
|
||||
application/vnd.adobe.air-application-installer-package+zip air
|
||||
application/vnd.adobe.formscentral.fcdt fcdt
|
||||
application/vnd.adobe.fxp fxpl fxp
|
||||
application/vnd.adobe.xdp+xml xdp
|
||||
application/vnd.adobe.xfdf xfdf
|
||||
application/vnd.ahead.space ahead
|
||||
application/vnd.airzip.filesecure.azf azf
|
||||
application/vnd.airzip.filesecure.azs azs
|
||||
application/vnd.amazon.ebook azw
|
||||
application/vnd.americandynamics.acc acc
|
||||
application/vnd.amiga.ami ami
|
||||
application/vnd.android.package-archive apk
|
||||
application/vnd.anser-web-certificate-issue-initiation cii
|
||||
application/vnd.anser-web-funds-transfer-initiation fti
|
||||
application/vnd.antix.game-component atx
|
||||
application/vnd.apple.installer+xml mpkg
|
||||
application/vnd.apple.mpegurl m3u8
|
||||
application/vnd.aristanetworks.swi swi
|
||||
application/vnd.astraea-software.iota iota
|
||||
application/vnd.audiograph aep
|
||||
application/vnd.blueice.multipass mpm
|
||||
application/vnd.bmi bmi
|
||||
application/vnd.businessobjects rep
|
||||
application/vnd.chemdraw+xml cdxml
|
||||
application/vnd.chipnuts.karaoke-mmd mmd
|
||||
application/vnd.cinderella cdy
|
||||
application/vnd.claymore cla
|
||||
application/vnd.cloanto.rp9 rp9
|
||||
application/vnd.clonk.c4group c4u c4p c4g c4f c4d
|
||||
application/vnd.cluetrust.cartomobile-config c11amc
|
||||
application/vnd.cluetrust.cartomobile-config-pkg c11amz
|
||||
application/vnd.commonspace csp
|
||||
application/vnd.contact.cmsg cdbcmsg
|
||||
application/vnd.cosmocaller cmc
|
||||
application/vnd.crick.clicker clkx
|
||||
application/vnd.crick.clicker.keyboard clkk
|
||||
application/vnd.crick.clicker.palette clkp
|
||||
application/vnd.crick.clicker.template clkt
|
||||
application/vnd.crick.clicker.wordbank clkw
|
||||
application/vnd.criticaltools.wbs+xml wbs
|
||||
application/vnd.ctc-posml pml
|
||||
application/vnd.cups-ppd ppd
|
||||
application/vnd.curl.car car
|
||||
application/vnd.curl.pcurl pcurl
|
||||
application/vnd.dart dart
|
||||
application/vnd.data-vision.rdz rdz
|
||||
application/vnd.dece.data uvvf uvvd uvf uvd
|
||||
application/vnd.dece.ttml+xml uvvt uvt
|
||||
application/vnd.dece.unspecified uvx uvvx
|
||||
application/vnd.dece.zip uvz uvvz
|
||||
application/vnd.denovo.fcselayout-link fe_launch
|
||||
application/vnd.dna dna
|
||||
application/vnd.dolby.mlp mlp
|
||||
application/vnd.dpgraph dpg
|
||||
application/vnd.dreamfactory dfac
|
||||
application/vnd.ds-keypoint kpxx
|
||||
application/vnd.dvb.ait ait
|
||||
application/vnd.dvb.service svc
|
||||
application/vnd.dynageo geo
|
||||
application/vnd.ecowin.chart mag
|
||||
application/vnd.enliven nml
|
||||
application/vnd.epson.esf esf
|
||||
application/vnd.epson.msf msf
|
||||
application/vnd.epson.quickanime qam
|
||||
application/vnd.epson.salt slt
|
||||
application/vnd.epson.ssf ssf
|
||||
application/vnd.eszigno3+xml et3 es3
|
||||
application/vnd.ezpix-album ez2
|
||||
application/vnd.ezpix-package ez3
|
||||
application/vnd.fdf fdf
|
||||
application/vnd.fdsn.mseed mseed
|
||||
application/vnd.fdsn.seed seed dataless
|
||||
application/vnd.flographit gph
|
||||
application/vnd.fluxtime.clip ftc
|
||||
application/vnd.framemaker maker frame fm book
|
||||
application/vnd.frogans.fnc fnc
|
||||
application/vnd.frogans.ltf ltf
|
||||
application/vnd.fsc.weblaunch fsc
|
||||
application/vnd.fujitsu.oasys oas
|
||||
application/vnd.fujitsu.oasys2 oa2
|
||||
application/vnd.fujitsu.oasys3 oa3
|
||||
application/vnd.fujitsu.oasysgp fg5
|
||||
application/vnd.fujitsu.oasysprs bh2
|
||||
application/vnd.fujixerox.ddd ddd
|
||||
application/vnd.fujixerox.docuworks xdw
|
||||
application/vnd.fujixerox.docuworks.binder xbd
|
||||
application/vnd.fuzzysheet fzs
|
||||
application/vnd.genomatix.tuxedo txd
|
||||
application/vnd.geogebra.file ggb
|
||||
application/vnd.geogebra.tool ggt
|
||||
application/vnd.geometry-explorer gre gex
|
||||
application/vnd.geonext gxt
|
||||
application/vnd.geoplan g2w
|
||||
application/vnd.geospace g3w
|
||||
application/vnd.gmx gmx
|
||||
application/vnd.google-earth.kml+xml kml
|
||||
application/vnd.google-earth.kmz kmz
|
||||
application/vnd.grafeq gqs gqf
|
||||
application/vnd.groove-account gac
|
||||
application/vnd.groove-help ghf
|
||||
application/vnd.groove-identity-message gim
|
||||
application/vnd.groove-injector grv
|
||||
application/vnd.groove-tool-message gtm
|
||||
application/vnd.groove-tool-template tpl
|
||||
application/vnd.groove-vcard vcg
|
||||
application/vnd.hal+xml hal
|
||||
application/vnd.handheld-entertainment+xml zmm
|
||||
application/vnd.hbci hbci
|
||||
application/vnd.hhe.lesson-player les
|
||||
application/vnd.hp-hpgl hpgl
|
||||
application/vnd.hp-hpid hpid
|
||||
application/vnd.hp-hps hps
|
||||
application/vnd.hp-jlyt jlt
|
||||
application/vnd.hp-pcl pcl
|
||||
application/vnd.hp-pclxl pclxl
|
||||
application/vnd.hydrostatix.sof-data sfd-hdstx
|
||||
application/vnd.ibm.minipay mpy
|
||||
application/vnd.ibm.modcap listafp list3820 afp
|
||||
application/vnd.ibm.rights-management irm
|
||||
application/vnd.ibm.secure-container sc
|
||||
application/vnd.iccprofile icm icc
|
||||
application/vnd.igloader igl
|
||||
application/vnd.immervision-ivp ivp
|
||||
application/vnd.immervision-ivu ivu
|
||||
application/vnd.insors.igm igm
|
||||
application/vnd.intercon.formnet xpx xpw
|
||||
application/vnd.intergeo i2g
|
||||
application/vnd.intu.qbo qbo
|
||||
application/vnd.intu.qfx qfx
|
||||
application/vnd.ipunplugged.rcprofile rcprofile
|
||||
application/vnd.irepository.package+xml irp
|
||||
application/vnd.is-xpr xpr
|
||||
application/vnd.isac.fcs fcs
|
||||
application/vnd.jam jam
|
||||
application/vnd.jcp.javame.midlet-rms rms
|
||||
application/vnd.jisp jisp
|
||||
application/vnd.joost.joda-archive joda
|
||||
application/vnd.kahootz ktz ktr
|
||||
application/vnd.kde.karbon karbon
|
||||
application/vnd.kde.kchart chrt
|
||||
application/vnd.kde.kformula kfo
|
||||
application/vnd.kde.kivio flw
|
||||
application/vnd.kde.kontour kon
|
||||
application/vnd.kde.kpresenter kpt kpr
|
||||
application/vnd.kde.kspread ksp
|
||||
application/vnd.kde.kword kwt kwd
|
||||
application/vnd.kenameaapp htke
|
||||
application/vnd.kidspiration kia
|
||||
application/vnd.kinar knp kne
|
||||
application/vnd.koan skt skp skm skd
|
||||
application/vnd.kodak-descriptor sse
|
||||
application/vnd.las.las+xml lasxml
|
||||
application/vnd.llamagraphics.life-balance.desktop lbd
|
||||
application/vnd.llamagraphics.life-balance.exchange+xml lbe
|
||||
application/vnd.lotus-1-2-3 123
|
||||
application/vnd.lotus-approach apr
|
||||
application/vnd.lotus-freelance pre
|
||||
application/vnd.lotus-notes nsf
|
||||
application/vnd.lotus-organizer org
|
||||
application/vnd.lotus-screencam scm
|
||||
application/vnd.lotus-wordpro lwp
|
||||
application/vnd.macports.portpkg portpkg
|
||||
application/vnd.mcd mcd
|
||||
application/vnd.medcalcdata mc1
|
||||
application/vnd.mediastation.cdkey cdkey
|
||||
application/vnd.mfer mwf
|
||||
application/vnd.mfmp mfm
|
||||
application/vnd.micrografx.flo flo
|
||||
application/vnd.micrografx.igx igx
|
||||
application/vnd.mif mif
|
||||
application/vnd.mobius.daf daf
|
||||
application/vnd.mobius.dis dis
|
||||
application/vnd.mobius.mbk mbk
|
||||
application/vnd.mobius.mqy mqy
|
||||
application/vnd.mobius.msl msl
|
||||
application/vnd.mobius.plc plc
|
||||
application/vnd.mobius.txf txf
|
||||
application/vnd.mophun.application mpn
|
||||
application/vnd.mophun.certificate mpc
|
||||
application/vnd.mozilla.xul+xml xul
|
||||
application/vnd.ms-artgalry cil
|
||||
application/vnd.ms-cab-compressed cab
|
||||
application/vnd.ms-excel xlw xlt xls xlm xlc xla
|
||||
application/vnd.ms-excel.addin.macroenabled.12 xlam
|
||||
application/vnd.ms-excel.sheet.binary.macroenabled.12 xlsb
|
||||
application/vnd.ms-excel.sheet.macroenabled.12 xlsm
|
||||
application/vnd.ms-excel.template.macroenabled.12 xltm
|
||||
application/vnd.ms-fontobject eot
|
||||
application/vnd.ms-htmlhelp chm
|
||||
application/vnd.ms-ims ims
|
||||
application/vnd.ms-lrm lrm
|
||||
application/vnd.ms-officetheme thmx
|
||||
application/vnd.ms-pki.seccat cat
|
||||
application/vnd.ms-pki.stl stl
|
||||
application/vnd.ms-powerpoint ppt pps pot
|
||||
application/vnd.ms-powerpoint.addin.macroenabled.12 ppam
|
||||
application/vnd.ms-powerpoint.presentation.macroenabled.12 pptm
|
||||
application/vnd.ms-powerpoint.slide.macroenabled.12 sldm
|
||||
application/vnd.ms-powerpoint.slideshow.macroenabled.12 ppsm
|
||||
application/vnd.ms-powerpoint.template.macroenabled.12 potm
|
||||
application/vnd.ms-project mpt mpp
|
||||
application/vnd.ms-word.document.macroenabled.12 docm
|
||||
application/vnd.ms-word.template.macroenabled.12 dotm
|
||||
application/vnd.ms-works wps wks wdb wcm
|
||||
application/vnd.ms-wpl wpl
|
||||
application/vnd.ms-xpsdocument xps
|
||||
application/vnd.mseq mseq
|
||||
application/vnd.musician mus
|
||||
application/vnd.muvee.style msty
|
||||
application/vnd.mynfc taglet
|
||||
application/vnd.neurolanguage.nlu nlu
|
||||
application/vnd.nitf ntf nitf
|
||||
application/vnd.noblenet-directory nnd
|
||||
application/vnd.noblenet-sealer nns
|
||||
application/vnd.noblenet-web nnw
|
||||
application/vnd.nokia.n-gage.data ngdat
|
||||
application/vnd.nokia.n-gage.symbian.install n-gage
|
||||
application/vnd.nokia.radio-preset rpst
|
||||
application/vnd.nokia.radio-presets rpss
|
||||
application/vnd.novadigm.edm edm
|
||||
application/vnd.novadigm.edx edx
|
||||
application/vnd.novadigm.ext ext
|
||||
application/vnd.oasis.opendocument.chart odc
|
||||
application/vnd.oasis.opendocument.chart-template otc
|
||||
application/vnd.oasis.opendocument.database odb
|
||||
application/vnd.oasis.opendocument.formula odf
|
||||
application/vnd.oasis.opendocument.formula-template odft
|
||||
application/vnd.oasis.opendocument.graphics odg
|
||||
application/vnd.oasis.opendocument.graphics-template otg
|
||||
application/vnd.oasis.opendocument.image odi
|
||||
application/vnd.oasis.opendocument.image-template oti
|
||||
application/vnd.oasis.opendocument.presentation odp
|
||||
application/vnd.oasis.opendocument.presentation-template otp
|
||||
application/vnd.oasis.opendocument.spreadsheet ods
|
||||
application/vnd.oasis.opendocument.spreadsheet-template ots
|
||||
application/vnd.oasis.opendocument.text odt
|
||||
application/vnd.oasis.opendocument.text-master odm
|
||||
application/vnd.oasis.opendocument.text-template ott
|
||||
application/vnd.oasis.opendocument.text-web oth
|
||||
application/vnd.olpc-sugar xo
|
||||
application/vnd.oma.dd2+xml dd2
|
||||
application/vnd.openofficeorg.extension oxt
|
||||
application/vnd.openxmlformats-officedocument.presentationml.presentation pptx
|
||||
application/vnd.openxmlformats-officedocument.presentationml.slide sldx
|
||||
application/vnd.openxmlformats-officedocument.presentationml.slideshow ppsx
|
||||
application/vnd.openxmlformats-officedocument.presentationml.template potx
|
||||
application/vnd.openxmlformats-officedocument.spreadsheetml.sheet xlsx
|
||||
application/vnd.openxmlformats-officedocument.spreadsheetml.template xltx
|
||||
application/vnd.openxmlformats-officedocument.wordprocessingml.document docx
|
||||
application/vnd.openxmlformats-officedocument.wordprocessingml.template dotx
|
||||
application/vnd.osgeo.mapguide.package mgp
|
||||
application/vnd.osgi.dp dp
|
||||
application/vnd.osgi.subsystem esa
|
||||
application/vnd.palm pqa pdb oprc
|
||||
application/vnd.pawaafile paw
|
||||
application/vnd.pg.format str
|
||||
application/vnd.pg.osasli ei6
|
||||
application/vnd.picsel efif
|
||||
application/vnd.pmi.widget wg
|
||||
application/vnd.pocketlearn plf
|
||||
application/vnd.powerbuilder6 pbd
|
||||
application/vnd.previewsystems.box box
|
||||
application/vnd.proteus.magazine mgz
|
||||
application/vnd.publishare-delta-tree qps
|
||||
application/vnd.pvi.ptid1 ptid
|
||||
application/vnd.quark.quarkxpress qxt qxl qxd qxb qwt qwd
|
||||
application/vnd.realvnc.bed bed
|
||||
application/vnd.recordare.musicxml mxl
|
||||
application/vnd.recordare.musicxml+xml musicxml
|
||||
application/vnd.rig.cryptonote cryptonote
|
||||
application/vnd.rim.cod cod
|
||||
application/vnd.rn-realmedia rm
|
||||
application/vnd.rn-realmedia-vbr rmvb
|
||||
application/vnd.route66.link66+xml link66
|
||||
application/vnd.sailingtracker.track st
|
||||
application/vnd.seemail see
|
||||
application/vnd.sema sema
|
||||
application/vnd.semd semd
|
||||
application/vnd.semf semf
|
||||
application/vnd.shana.informed.formdata ifm
|
||||
application/vnd.shana.informed.formtemplate itp
|
||||
application/vnd.shana.informed.interchange iif
|
||||
application/vnd.shana.informed.package ipk
|
||||
application/vnd.simtech-mindmapper twds twd
|
||||
application/vnd.smaf mmf
|
||||
application/vnd.smart.teacher teacher
|
||||
application/vnd.solent.sdkm+xml sdkm sdkd
|
||||
application/vnd.spotfire.dxp dxp
|
||||
application/vnd.spotfire.sfs sfs
|
||||
application/vnd.stardivision.calc sdc
|
||||
application/vnd.stardivision.draw sda
|
||||
application/vnd.stardivision.impress sdd
|
||||
application/vnd.stardivision.math smf
|
||||
application/vnd.stardivision.writer vor sdw
|
||||
application/vnd.stardivision.writer-global sgl
|
||||
application/vnd.stepmania.package smzip
|
||||
application/vnd.stepmania.stepchart sm
|
||||
application/vnd.sun.xml.calc sxc
|
||||
application/vnd.sun.xml.calc.template stc
|
||||
application/vnd.sun.xml.draw sxd
|
||||
application/vnd.sun.xml.draw.template std
|
||||
application/vnd.sun.xml.impress sxi
|
||||
application/vnd.sun.xml.impress.template sti
|
||||
application/vnd.sun.xml.math sxm
|
||||
application/vnd.sun.xml.writer sxw
|
||||
application/vnd.sun.xml.writer.global sxg
|
||||
application/vnd.sun.xml.writer.template stw
|
||||
application/vnd.sus-calendar susp sus
|
||||
application/vnd.svd svd
|
||||
application/vnd.symbian.install sisx sis
|
||||
application/vnd.syncml+xml xsm
|
||||
application/vnd.syncml.dm+wbxml bdm
|
||||
application/vnd.syncml.dm+xml xdm
|
||||
application/vnd.tao.intent-module-archive tao
|
||||
application/vnd.tcpdump.pcap pcap dmp cap
|
||||
application/vnd.tmobile-livetv tmo
|
||||
application/vnd.trid.tpt tpt
|
||||
application/vnd.triscape.mxs mxs
|
||||
application/vnd.trueapp tra
|
||||
application/vnd.ufdl ufdl ufd
|
||||
application/vnd.uiq.theme utz
|
||||
application/vnd.umajin umj
|
||||
application/vnd.unity unityweb
|
||||
application/vnd.uoml+xml uoml
|
||||
application/vnd.vcx vcx
|
||||
application/vnd.visio vsw vst vss vsd
|
||||
application/vnd.visionary vis
|
||||
application/vnd.vsf vsf
|
||||
application/vnd.wap.wbxml wbxml
|
||||
application/vnd.wap.wmlc wmlc
|
||||
application/vnd.wap.wmlscriptc wmlsc
|
||||
application/vnd.webturbo wtb
|
||||
application/vnd.wolfram.player nbp
|
||||
application/vnd.wordperfect wpd
|
||||
application/vnd.wqd wqd
|
||||
application/vnd.wt.stf stf
|
||||
application/vnd.xara xar
|
||||
application/vnd.xfdl xfdl
|
||||
application/vnd.yamaha.hv-dic hvd
|
||||
application/vnd.yamaha.hv-script hvs
|
||||
application/vnd.yamaha.hv-voice hvp
|
||||
application/vnd.yamaha.openscoreformat osf
|
||||
application/vnd.yamaha.openscoreformat.osfpvg+xml osfpvg
|
||||
application/vnd.yamaha.smaf-audio saf
|
||||
application/vnd.yamaha.smaf-phrase spf
|
||||
application/vnd.yellowriver-custom-menu cmp
|
||||
application/vnd.zul zirz zir
|
||||
application/vnd.zzazz.deck+xml zaz
|
||||
application/voicexml+xml vxml
|
||||
application/widget wgt
|
||||
application/winhlp hlp
|
||||
application/wsdl+xml wsdl
|
||||
application/wspolicy+xml wspolicy
|
||||
application/x-7z-compressed 7z
|
||||
application/x-abiword abw
|
||||
application/x-ace-compressed ace
|
||||
application/x-apple-diskimage dmg
|
||||
application/x-authorware-bin x32 vox u32 aab
|
||||
application/x-authorware-map aam
|
||||
application/x-authorware-seg aas
|
||||
application/x-bcpio bcpio
|
||||
application/x-bittorrent torrent
|
||||
application/x-blorb blorb blb
|
||||
application/x-bzip bz2 bz
|
||||
application/x-bzip-compressed-tar tbz tar.bz2
|
||||
application/x-bzip2 boz
|
||||
application/x-cbr cbz cbt cbr cba cb7
|
||||
application/x-cdlink vcd
|
||||
application/x-cfs-compressed cfs
|
||||
application/x-chat chat
|
||||
application/x-chess-pgn pgn
|
||||
application/x-cocoa cco
|
||||
application/x-conference nsc
|
||||
application/x-cpio cpio
|
||||
application/x-csh csh
|
||||
application/x-debian-package udeb deb
|
||||
application/x-dgc-compressed dgc
|
||||
application/x-director w3d swa fgd dxr dir dcr cxt cst cct
|
||||
application/x-doom wad
|
||||
application/x-dtbncx+xml ncx
|
||||
application/x-dtbook+xml dtb
|
||||
application/x-dtbresource+xml res
|
||||
application/x-dvi dvi
|
||||
application/x-envoy evy
|
||||
application/x-eva eva
|
||||
application/x-font-bdf bdf
|
||||
application/x-font-ghostscript gsf
|
||||
application/x-font-linux-psf psf
|
||||
application/x-font-otf otf
|
||||
application/x-font-pcf pcf
|
||||
application/x-font-snf snf
|
||||
application/x-font-ttf ttf ttc
|
||||
application/x-font-type1 pfm pfb pfa afm
|
||||
application/x-freearc arc
|
||||
application/x-gca-compressed gca
|
||||
application/x-glulx ulx
|
||||
application/x-gnumeric gnumeric
|
||||
application/x-gramps-xml gramps
|
||||
application/x-gtar gtar
|
||||
application/x-gzip gz
|
||||
application/x-hdf hdf
|
||||
application/x-install-instructions install
|
||||
application/x-iso9660-image iso
|
||||
application/x-java-archive-diff jardiff
|
||||
application/x-java-jnlp-file jnlp
|
||||
application/x-latex latex
|
||||
application/x-lzh-compressed lzh lha
|
||||
application/x-makeself run
|
||||
application/x-mie mie
|
||||
application/x-mobipocket-ebook prc mobi
|
||||
application/x-ms-application application
|
||||
application/x-ms-shortcut lnk
|
||||
application/x-ms-wmd wmd
|
||||
application/x-ms-xbap xbap
|
||||
application/x-msaccess mdb
|
||||
application/x-msbinder obd
|
||||
application/x-mscardfile crd
|
||||
application/x-msclip clp
|
||||
application/x-msdownload msi exe dll com bat
|
||||
application/x-msmediaview mvb m14 m13
|
||||
application/x-msmetafile wmz wmf emz emf
|
||||
application/x-msmoney mny
|
||||
application/x-mspublisher pub
|
||||
application/x-msschedule scd
|
||||
application/x-msterminal trm
|
||||
application/x-mswrite wri
|
||||
application/x-netcdf nc cdf
|
||||
application/x-ns-proxy-autoconfig pac
|
||||
application/x-nzb nzb
|
||||
application/x-perl pm pl
|
||||
application/x-pkcs12 pfx p12
|
||||
application/x-pkcs7-certificates spc p7b
|
||||
application/x-pkcs7-certreqresp p7r
|
||||
application/x-rar-compressed rar
|
||||
application/x-redhat-package-manager rpm
|
||||
application/x-research-info-systems ris
|
||||
application/x-sea sea
|
||||
application/x-sh sh
|
||||
application/x-shar shar
|
||||
application/x-shockwave-flash swf
|
||||
application/x-silverlight-app xap
|
||||
application/x-sql sql
|
||||
application/x-stuffit sit
|
||||
application/x-stuffitx sitx
|
||||
application/x-subrip srt
|
||||
application/x-sv4cpio sv4cpio
|
||||
application/x-sv4crc sv4crc
|
||||
application/x-t3vm-image t3
|
||||
application/x-tads gam
|
||||
application/x-tar tar
|
||||
application/x-tcl tk tcl
|
||||
application/x-tex tex
|
||||
application/x-tex-tfm tfm
|
||||
application/x-texinfo texinfo texi
|
||||
application/x-tgif obj
|
||||
application/x-tgz tgz tar.gz
|
||||
application/x-ustar ustar
|
||||
application/x-wais-source src
|
||||
application/x-x509-ca-cert pem der crt
|
||||
application/x-xfig fig
|
||||
application/x-xliff+xml xlf
|
||||
application/x-xpinstall xpi
|
||||
application/x-xz xz
|
||||
application/x-zmachine z8 z7 z6 z5 z4 z3 z2 z1
|
||||
application/xaml+xml xaml
|
||||
application/xcap-diff+xml xdf
|
||||
application/xenc+xml xenc
|
||||
application/xhtml+xml xhtml xht
|
||||
application/xml xsl
|
||||
application/xml-dtd dtd
|
||||
application/xop+xml xop
|
||||
application/xproc+xml xpl
|
||||
application/xslt+xml xslt
|
||||
application/xspf+xml xspf
|
||||
application/xv+xml xvml xvm xhvml mxml
|
||||
application/yang yang
|
||||
application/yin+xml yin
|
||||
application/zip zip
|
||||
audio/adpcm adp
|
||||
audio/basic snd au
|
||||
audio/midi rmi midi mid kar
|
||||
audio/mp4 mp4a
|
||||
audio/mpeg mpga mp3 mp2a mp2 m3a m2a
|
||||
audio/ogg spx ogg oga
|
||||
audio/s3m s3m
|
||||
audio/silk sil
|
||||
audio/vnd.dece.audio uvva uva
|
||||
audio/vnd.digital-winds eol
|
||||
audio/vnd.dra dra
|
||||
audio/vnd.dts dts
|
||||
audio/vnd.dts.hd dtshd
|
||||
audio/vnd.lucent.voice lvp
|
||||
audio/vnd.ms-playready.media.pya pya
|
||||
audio/vnd.nuera.ecelp4800 ecelp4800
|
||||
audio/vnd.nuera.ecelp7470 ecelp7470
|
||||
audio/vnd.nuera.ecelp9600 ecelp9600
|
||||
audio/vnd.rip rip
|
||||
audio/webm weba
|
||||
audio/x-aac aac
|
||||
audio/x-aiff aiff aifc aif
|
||||
audio/x-caf caf
|
||||
audio/x-flac flac
|
||||
audio/x-m4a m4a
|
||||
audio/x-matroska mka
|
||||
audio/x-mpegurl m3u
|
||||
audio/x-ms-wax wax
|
||||
audio/x-ms-wma wma
|
||||
audio/x-pn-realaudio ram ra
|
||||
audio/x-pn-realaudio-plugin rmp
|
||||
audio/x-wav wav
|
||||
audio/xm xm
|
||||
chemical/x-cdx cdx
|
||||
chemical/x-cif cif
|
||||
chemical/x-cmdf cmdf
|
||||
chemical/x-cml cml
|
||||
chemical/x-csml csml
|
||||
chemical/x-xyz xyz
|
||||
image/bmp bmp
|
||||
image/cgm cgm
|
||||
image/g3fax g3
|
||||
image/gif gif
|
||||
image/ief ief
|
||||
image/jpeg jpg jpeg jpe
|
||||
image/ktx ktx
|
||||
image/png png
|
||||
image/prs.btif btif
|
||||
image/sgi sgi
|
||||
image/svg+xml svgz svg
|
||||
image/tiff tiff tif
|
||||
image/vnd.adobe.photoshop psd
|
||||
image/vnd.dece.graphic uvvi uvvg uvi uvg
|
||||
image/vnd.djvu djvu djv
|
||||
image/vnd.dwg dwg
|
||||
image/vnd.dxf dxf
|
||||
image/vnd.fastbidsheet fbs
|
||||
image/vnd.fpx fpx
|
||||
image/vnd.fst fst
|
||||
image/vnd.fujixerox.edmics-mmr mmr
|
||||
image/vnd.fujixerox.edmics-rlc rlc
|
||||
image/vnd.microsoft.icon ico
|
||||
image/vnd.ms-modi mdi
|
||||
image/vnd.ms-photo wdp
|
||||
image/vnd.net-fpx npx
|
||||
image/vnd.wap.wbmp wbmp
|
||||
image/vnd.xiff xif
|
||||
image/webp webp
|
||||
image/x-3ds 3ds
|
||||
image/x-cmu-raster ras
|
||||
image/x-cmx cmx
|
||||
image/x-freehand fhc fh7 fh5 fh4 fh
|
||||
image/x-jng jng
|
||||
image/x-mrsid-image sid
|
||||
image/x-pcx pcx
|
||||
image/x-pict pic pct
|
||||
image/x-portable-anymap pnm
|
||||
image/x-portable-bitmap pbm
|
||||
image/x-portable-graymap pgm
|
||||
image/x-portable-pixmap ppm
|
||||
image/x-rgb rgb
|
||||
image/x-tga tga
|
||||
image/x-xbitmap xbm
|
||||
image/x-xpixmap xpm
|
||||
image/x-xwindowdump xwd
|
||||
message/rfc822 mime eml
|
||||
model/iges igs iges
|
||||
model/mesh silo msh mesh
|
||||
model/vnd.collada+xml dae
|
||||
model/vnd.dwf dwf
|
||||
model/vnd.gdl gdl
|
||||
model/vnd.gtw gtw
|
||||
model/vnd.mts mts
|
||||
model/vnd.vtu vtu
|
||||
model/vrml wrl vrml
|
||||
model/x3d+binary x3dbz x3db
|
||||
model/x3d+vrml x3dvz x3dv
|
||||
model/x3d+xml x3dz x3d
|
||||
text/cache-manifest manifest appcache
|
||||
text/calendar ifb ics
|
||||
text/css less css
|
||||
text/csv csv
|
||||
text/html shtml html htm
|
||||
text/mathml mml
|
||||
text/n3 n3
|
||||
text/plain txt text log list in hs def cxx cpp conf c asc
|
||||
text/prs.lines.tag dsc
|
||||
text/richtext rtx
|
||||
text/sgml sgml sgm
|
||||
text/tab-separated-values tsv
|
||||
text/troff tr t roff ms me man
|
||||
text/turtle ttl
|
||||
text/uri-list urls uris uri
|
||||
text/vcard vcard
|
||||
text/vnd.curl curl
|
||||
text/vnd.curl.dcurl dcurl
|
||||
text/vnd.curl.mcurl mcurl
|
||||
text/vnd.curl.scurl scurl
|
||||
text/vnd.dvb.subtitle sub
|
||||
text/vnd.fly fly
|
||||
text/vnd.fmi.flexstor flx
|
||||
text/vnd.graphviz gv
|
||||
text/vnd.in3d.3dml 3dml
|
||||
text/vnd.in3d.spot spot
|
||||
text/vnd.sun.j2me.app-descriptor jad
|
||||
text/vnd.wap.wml wml
|
||||
text/vnd.wap.wmlscript wmls
|
||||
text/x-asm s asm
|
||||
text/x-c hh h dic cc
|
||||
text/x-component htc
|
||||
text/x-fortran for f90 f77 f
|
||||
text/x-java-source java
|
||||
text/x-nfo nfo
|
||||
text/x-opml opml
|
||||
text/x-pascal pas p
|
||||
text/x-setext etx
|
||||
text/x-sfv sfv
|
||||
text/x-uuencode uu
|
||||
text/x-vcalendar vcs
|
||||
text/x-vcard vcf
|
||||
text/xml xml
|
||||
video/3gpp 3gpp 3gp
|
||||
video/3gpp2 3g2
|
||||
video/h261 h261
|
||||
video/h263 h263
|
||||
video/h264 h264
|
||||
video/jpeg jpgv
|
||||
video/jpm jpm jpgm
|
||||
video/mj2 mjp2 mj2
|
||||
video/mp4 mpg4 mp4v mp4
|
||||
video/mpeg mpg mpeg mpe m2v m1v
|
||||
video/ogg ogv
|
||||
video/quicktime qt mov
|
||||
video/vnd.dece.hd uvvh uvh
|
||||
video/vnd.dece.mobile uvvm uvm
|
||||
video/vnd.dece.pd uvvp uvp
|
||||
video/vnd.dece.sd uvvs uvs
|
||||
video/vnd.dece.video uvvv uvv
|
||||
video/vnd.dvb.file dvb
|
||||
video/vnd.fvt fvt
|
||||
video/vnd.mpegurl mxu m4u
|
||||
video/vnd.ms-playready.media.pyv pyv
|
||||
video/vnd.uvvu.mp4 uvvu uvu
|
||||
video/vnd.vivo viv
|
||||
video/webm webm
|
||||
video/x-f4v f4v
|
||||
video/x-fli fli
|
||||
video/x-flv flv
|
||||
video/x-m4v m4v
|
||||
video/x-matroska mkv mks mk3d
|
||||
video/x-mng mng
|
||||
video/x-ms-asf asx asf
|
||||
video/x-ms-vob vob
|
||||
video/x-ms-wm wm
|
||||
video/x-ms-wmv wmv
|
||||
video/x-ms-wmx wmx
|
||||
video/x-ms-wvx wvx
|
||||
video/x-msvideo avi
|
||||
video/x-sgi-movie movie
|
||||
video/x-smv smv
|
||||
x-conference/x-cooltalk ice
|
||||
@ -29,7 +29,7 @@ notification-expiration: 259201
|
||||
session-timeout: 7200
|
||||
jwt-expiration: 604800
|
||||
jwt-encoding: HS256
|
||||
maximum-content-length: 52428800
|
||||
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
|
||||
health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller
|
||||
health-check-http: "_env:HEALTHCHECK_HTTP:true"
|
||||
health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
|
||||
@ -64,6 +64,8 @@ database:
|
||||
database: "_env:PGDATABASE:uniworx"
|
||||
poolsize: "_env:PGPOOLSIZE:10"
|
||||
|
||||
auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
|
||||
|
||||
ldap:
|
||||
host: "_env:LDAPHOST:"
|
||||
tls: "_env:LDAPTLS:"
|
||||
|
||||
@ -7,6 +7,8 @@ BtnRegister: Anmelden
|
||||
BtnDeregister: Abmelden
|
||||
BtnHijack: Sitzung übernehmen
|
||||
BtnSave: Speichern
|
||||
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.
|
||||
BtnHandIn: Abgeben
|
||||
BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
|
||||
BtnCandidatesDeleteConflicts: Konflikte löschen
|
||||
BtnCandidatesDeleteAll: Alle Beobachtungen löschen
|
||||
@ -16,11 +18,12 @@ BtnLecInvDecline: Ablehnen
|
||||
BtnCorrInvAccept: Annehmen
|
||||
BtnCorrInvDecline: Ablehnen
|
||||
|
||||
|
||||
|
||||
Aborted: Abgebrochen
|
||||
Remarks: Hinweise
|
||||
Registered: Angemeldet
|
||||
RegisteredHeader: Anmeldung
|
||||
RegisteredSince date@Text: Angemeldet seit #{date}
|
||||
RegisteredSince: Angemeldet seit
|
||||
RegisterFrom: Anmeldungen von
|
||||
RegisterTo: Anmeldungen bis
|
||||
DeRegUntil: Abmeldungen bis
|
||||
@ -74,7 +77,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
|
||||
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
|
||||
CourseRegisterOk: Anmeldung erfolgreich
|
||||
CourseDeregisterOk: Erfolgreich abgemeldet
|
||||
CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
|
||||
CourseStudyFeature: Assoziiertes Hauptfach
|
||||
CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert
|
||||
CourseTutorial: Tutorium
|
||||
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
@ -198,11 +203,14 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
|
||||
SubmissionMember n@Int: Mitabgebende(r) ##{display n}
|
||||
SubmissionMembers: Abgebende
|
||||
SubmissionMember: Abgebende(r)
|
||||
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
SubmissionFiles: Abgegebene Dateien
|
||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionUsersEmpty: Es kann keine Abgabe ohne Abgebende erstellt werden
|
||||
SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) eingetragen
|
||||
|
||||
SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
|
||||
SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}
|
||||
@ -408,6 +416,7 @@ RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
|
||||
ColumnRatingPoints: Punktzahl
|
||||
Pseudonyms: Pseudonyme
|
||||
|
||||
Files: Dateien
|
||||
FileTitle: Dateiname
|
||||
FileModified: Letzte Änderung
|
||||
VisibleFrom: Veröffentlicht
|
||||
@ -508,6 +517,7 @@ BothSubmissions: Abgabe direkt & extern mit Pseudonym
|
||||
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
|
||||
|
||||
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
|
||||
SubmissionReplace: Abgabe ersetzen
|
||||
|
||||
AdminFeaturesHeading: Studiengänge
|
||||
StudyTerms: Studiengänge
|
||||
@ -582,10 +592,14 @@ CommCourseSubject: Kursmitteilung
|
||||
MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
|
||||
InvitationAcceptDecline: Einladung annehmen/ablehnen
|
||||
|
||||
MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursteilname
|
||||
|
||||
MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
|
||||
|
||||
MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
|
||||
|
||||
MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
|
||||
|
||||
SheetGrading: Bewertung
|
||||
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
|
||||
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
|
||||
@ -743,6 +757,7 @@ MenuLogin: Login
|
||||
MenuLogout: Logout
|
||||
MenuCourseList: Kurse
|
||||
MenuCourseMembers: Kursteilnehmer
|
||||
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
||||
MenuCourseCommunication: Kursmitteilung
|
||||
MenuTermShow: Semester
|
||||
MenuSubmissionDelete: Abgabe löschen
|
||||
@ -784,6 +799,7 @@ MenuCorrectionsGrade: Abgaben bewerten
|
||||
MenuAuthPreds: Authorisierungseinstellungen
|
||||
MenuTutorialDelete: Tutorium löschen
|
||||
MenuTutorialEdit: Tutorium editieren
|
||||
MenuTutorialComm: Mitteilung an Teilnehmer
|
||||
|
||||
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
|
||||
AuthPredsActive: Aktive Authorisierungsprädikate
|
||||
@ -853,6 +869,14 @@ LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursver
|
||||
CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
|
||||
CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
|
||||
|
||||
CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName}
|
||||
CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen.
|
||||
CourseParticipantEnlistDirectly: bekannte Teilnehmer sofort als Teilnehmer eintragen
|
||||
CourseParticipantInviteField: einzuladende EMail Adressen
|
||||
|
||||
CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen
|
||||
|
||||
|
||||
CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen
|
||||
CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
|
||||
SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
|
||||
@ -863,6 +887,11 @@ TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #
|
||||
TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
|
||||
TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
|
||||
|
||||
SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen
|
||||
SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt
|
||||
SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
|
||||
SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein.
|
||||
|
||||
InvitationAction: Aktion
|
||||
InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
|
||||
InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
|
||||
@ -930,7 +959,7 @@ TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt
|
||||
|
||||
TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten
|
||||
|
||||
MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden.
|
||||
MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Alle Änderungen müssen noch durch Drücken des Forumular-Knopfes bestätigt werden.
|
||||
|
||||
HealthReport: Instanz-Zustand
|
||||
InstanceIdentification: Instanz-Identifikation
|
||||
@ -943,3 +972,9 @@ HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werd
|
||||
HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können
|
||||
HealthSMTPConnect: SMTP-Server kann erreicht werden
|
||||
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
|
||||
|
||||
CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
|
||||
CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet
|
||||
CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen
|
||||
@ -33,7 +33,7 @@ CourseFavourite -- which user accessed which course when, only display
|
||||
Lecturer -- course ownership
|
||||
user UserId
|
||||
course CourseId
|
||||
type LecturerType default='"lecturer"'
|
||||
type LecturerType default='"lecturer"'::jsonb
|
||||
UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
|
||||
CourseParticipant -- course enrolement
|
||||
course CourseId
|
||||
|
||||
@ -9,7 +9,7 @@ Tutorial json
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
deregisterUntil UTCTime Maybe
|
||||
lastChanged UTCTime default='NOW()'
|
||||
lastChanged UTCTime default=now()
|
||||
UniqueTutorial course name
|
||||
Tutor
|
||||
tutorial TutorialId
|
||||
|
||||
@ -22,7 +22,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
|
||||
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
|
||||
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
|
||||
mailLanguages MailLanguages default='[]' -- Preferred language for eMail; i18n not yet implemented; user-defined
|
||||
mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
|
||||
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
|
||||
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
|
||||
UniqueEmail email -- Column 'email' can be used as a row-key in this table
|
||||
@ -41,7 +41,7 @@ StudyFeatures -- multiple entries possible for students pursuing several degree
|
||||
field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc.
|
||||
type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach
|
||||
semester Int
|
||||
updated UTCTime default='NOW()' -- last update from LDAP
|
||||
updated UTCTime default=now() -- last update from LDAP
|
||||
valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets)
|
||||
UniqueStudyFeatures user degree field type semester
|
||||
-- UniqueUserSubject ubuser degree field -- There exists a counterexample
|
||||
|
||||
@ -197,7 +197,7 @@ when:
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: (flag(dev)) || (flag(library-only))
|
||||
- condition: flag(dev)
|
||||
then:
|
||||
ghc-options:
|
||||
- -O0
|
||||
|
||||
15
routes
15
routes
@ -85,17 +85,19 @@
|
||||
/lecturer-invite CLecInviteR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET POST
|
||||
!/users/new CAddUserR GET POST
|
||||
!/users/invite CInviteR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
|
||||
/correctors CHiWisR GET
|
||||
/communication CCommR GET POST
|
||||
/notes CNotesR GET POST !corrector
|
||||
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
|
||||
/subs CCorrectionsR GET POST
|
||||
/ex SheetListR GET !course-registered !materials !corrector
|
||||
/ex/new SheetNewR GET POST
|
||||
/ex/current SheetCurrentR GET !course-registered !materials !corrector
|
||||
/ex/unassigned SheetOldUnassigned GET
|
||||
/ex/#SheetName SheetR:
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
/subs SSubsR GET POST -- for lecturer only
|
||||
@ -107,11 +109,14 @@
|
||||
/delete SubDelR GET POST !ownerANDtime
|
||||
/assign SAssignR GET POST !lecturerANDtime
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
/invite SInviteR GET POST !ownerANDtime
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
|
||||
/corrector-invite/ SCorrInviteR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
!/#{ZIPArchiveName SheetFileType} SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
/file MaterialListR GET !course-registered !materials !corrector !tutor
|
||||
/file/new MaterialNewR GET POST
|
||||
/file/#MaterialName MaterialR:
|
||||
@ -119,7 +124,9 @@
|
||||
/delete MDelR GET POST
|
||||
/show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/tuts CTutorialListR GET !tutor
|
||||
/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access!
|
||||
/tuts/new CTutorialNewR GET POST
|
||||
/tuts/#TutorialName TutorialR:
|
||||
/edit TEditR GET POST
|
||||
|
||||
@ -70,7 +70,7 @@ import Data.Proxy
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import System.Exit (exitFailure)
|
||||
import System.Exit
|
||||
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
@ -78,9 +78,14 @@ import qualified System.Systemd.Daemon as Systemd
|
||||
import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Posix.Process (getProcessID)
|
||||
import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
|
||||
import qualified System.Posix.Signals as Signals (Handler(..))
|
||||
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
|
||||
import Network (socketPort)
|
||||
import qualified Network.Socket as Socket (close)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
import Handler.Common
|
||||
@ -192,8 +197,13 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
$logDebugS "setup" "Migration"
|
||||
migrateAll `runSqlPool` sqlPool
|
||||
if
|
||||
| appAutoDbMigrate -> do
|
||||
$logDebugS "setup" "Migration"
|
||||
migrateAll `runSqlPool` sqlPool
|
||||
| otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do
|
||||
$logErrorS "setup" "Migration required"
|
||||
liftIO . exitWith $ ExitFailure 2
|
||||
$logDebugS "setup" "Cluster-Config"
|
||||
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
|
||||
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
|
||||
@ -339,7 +349,9 @@ warpSettings foundation = defaultSettings
|
||||
$(qLocation >>= liftLoc)
|
||||
"yesod"
|
||||
LevelError
|
||||
(toLogStr $ "Exception from Warp: " ++ show e))
|
||||
(toLogStr $ "Exception from Warp: " ++ show e)
|
||||
)
|
||||
|
||||
|
||||
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
|
||||
getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
|
||||
@ -385,9 +397,10 @@ appMain = runResourceT $ do
|
||||
-- Run the application with Warp
|
||||
activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames
|
||||
sockets <- case activatedSockets of
|
||||
Just socks@(_ : _) -> do
|
||||
$logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|]
|
||||
return $ fst <$> socks
|
||||
Just socks
|
||||
| not $ null socks -> do
|
||||
$logInfoS "bind" [st|Ignoring configuration and listening on #{intercalate ", " (fmap (tshow . snd) socks)}|]
|
||||
return $ fst <$> socks
|
||||
_other -> do
|
||||
let
|
||||
host = foundation ^. _appHost
|
||||
@ -395,6 +408,17 @@ appMain = runResourceT $ do
|
||||
$logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
|
||||
liftIO $ pure <$> bindPortTCP port host
|
||||
|
||||
$logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets
|
||||
|
||||
mainThreadId <- myThreadId
|
||||
liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
|
||||
$logInfoS "shutdown" [st|Received signal #{tshow siginfoSignal}|]
|
||||
didStore <- runMaybeT . forM_ sockets $ MaybeT . liftIO . Systemd.storeFd
|
||||
case didStore of
|
||||
Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
|
||||
Nothing -> forM_ sockets $ liftIO . Socket.close
|
||||
liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal
|
||||
|
||||
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
|
||||
case sockets of
|
||||
[] -> $logErrorS "bind" "No sockets to listen on"
|
||||
|
||||
@ -155,6 +155,11 @@ instance HasAppSettings UniWorX where
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
deriving instance Generic CourseR
|
||||
deriving instance Generic SheetR
|
||||
deriving instance Generic SubmissionR
|
||||
deriving instance Generic MaterialR
|
||||
deriving instance Generic TutorialR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
@ -503,13 +508,19 @@ validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo valid
|
||||
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
|
||||
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
||||
|
||||
let
|
||||
-- Prevent infinite loops
|
||||
noTokenAuth :: AuthDNF -> AuthDNF
|
||||
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
||||
|
||||
authorityVal <- do
|
||||
dnf <- either throwM return $ routeAuthTags route
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite
|
||||
guardExceptT (is _Authorized authorityVal) authorityVal
|
||||
|
||||
whenIsJust tokenAddAuth $ \addDNF -> do
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
|
||||
$logDebugS "validateToken" $ tshow addDNF
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
|
||||
guardExceptT (is _Authorized additionalVal) additionalVal
|
||||
|
||||
return Authorized
|
||||
@ -660,10 +671,17 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
guard visible
|
||||
|
||||
case subRoute of
|
||||
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
|
||||
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
|
||||
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SFileR _ _ -> mzero
|
||||
-- Single Files
|
||||
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
|
||||
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
|
||||
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SFileR _ _ -> mzero
|
||||
-- Archives of SheetFileType
|
||||
SZipR (ZIPArchiveName SheetExercise) -> guard $ sheetActiveFrom <= cTime
|
||||
SZipR (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom
|
||||
SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SZipR _ -> mzero
|
||||
-- Submissions
|
||||
SubmissionNewR -> guard active
|
||||
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
|
||||
SubmissionR _ _ -> guard active
|
||||
@ -1092,8 +1110,13 @@ instance Yesod UniWorX where
|
||||
headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
|
||||
$logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit)
|
||||
guard $ isModal || dbTableShortcircuit
|
||||
massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
|
||||
$logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
|
||||
guard $ or
|
||||
[ isModal
|
||||
, dbTableShortcircuit
|
||||
, massInputShortcircuit
|
||||
]
|
||||
|
||||
lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do
|
||||
Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
|
||||
@ -1248,7 +1271,7 @@ siteLayout' headingOverride widget = do
|
||||
applySystemMessages
|
||||
authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
|
||||
forM_ authTagPivots $
|
||||
\authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
|
||||
\authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
|
||||
getMessages
|
||||
|
||||
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
|
||||
@ -1356,6 +1379,10 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .|
|
||||
cID <- encrypt smId
|
||||
void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= NTop (Just now)
|
||||
guard $ NTop (Just now) < NTop systemMessageTo
|
||||
|
||||
let sessionKey = "sm-" <> tshow (ciphertext cID)
|
||||
_ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())
|
||||
setSessionJson sessionKey ()
|
||||
@ -1417,6 +1444,8 @@ instance YesodBreadcrumbs UniWorX where
|
||||
-- (CourseR tid ssh csh CRegisterR) -- is POST only
|
||||
breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CAddUserR) = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR)
|
||||
breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
|
||||
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
|
||||
@ -1814,8 +1843,8 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' =
|
||||
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers that can create new material
|
||||
materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- or show if user can see at least one of the contents
|
||||
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material
|
||||
materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents
|
||||
existsVisible = do
|
||||
matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do
|
||||
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
|
||||
@ -1832,17 +1861,18 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = do --TODO always show for lecturer
|
||||
let sheetRouteAccess shn = (== Authorized) <$> evalAccess (CSheetR tid ssh csh shn SShowR) False
|
||||
muid <- maybeAuthId
|
||||
(sheets,lecturer) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
|
||||
lecturer <- case muid of
|
||||
Nothing -> return False
|
||||
(Just uid) -> existsBy $ UniqueLecturer uid cid
|
||||
return (sheets,lecturer)
|
||||
or2M (return lecturer) $ anyM sheets sheetRouteAccess
|
||||
, menuItemAccessCallback' =
|
||||
let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets
|
||||
sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents
|
||||
existsVisible = do
|
||||
sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return $ sheet E.^. SheetName
|
||||
anyM sheetNames (sheetAccess . E.unValue)
|
||||
in runDB $ lecturerAccess `or2M` existsVisible
|
||||
}
|
||||
] ++ pageActions (CourseR tid ssh csh SheetListR) ++
|
||||
[ MenuItem
|
||||
@ -1955,6 +1985,16 @@ pageActions (CourseR tid ssh csh SheetListR) =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid ssh csh CUsersR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuCourseAddMembers
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid ssh csh MaterialListR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
@ -2005,6 +2045,14 @@ pageActions (CTutorialR tid ssh csh tutn TEditR) =
|
||||
]
|
||||
pageActions (CTutorialR tid ssh csh tutn TUsersR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuTutorialComm
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuTutorialEdit
|
||||
, menuItemIcon = Nothing
|
||||
@ -2108,6 +2156,14 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuSubmissionNew
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
|
||||
[ MenuItem
|
||||
@ -2409,7 +2465,9 @@ routeNormalizers =
|
||||
-- How to run database actions.
|
||||
instance YesodPersist UniWorX where
|
||||
type YesodPersistBackend UniWorX = SqlBackend
|
||||
runDB action = runSqlPool action =<< appConnPool <$> getYesod
|
||||
runDB action = do
|
||||
$logDebugS "YesodPersist" "runDB"
|
||||
runSqlPool action =<< appConnPool <$> getYesod
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
|
||||
|
||||
@ -191,12 +191,10 @@ postAdminTestR = do
|
||||
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
||||
return (intRes, toWidget csrf >> fvInput intView)
|
||||
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
||||
deleteCell :: ListLength -- ^ Current shape
|
||||
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
||||
deleteCell l pos
|
||||
| l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
||||
| otherwise = return Map.empty
|
||||
deleteCell = miDeleteList
|
||||
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
||||
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
||||
|
||||
@ -196,7 +196,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
|
||||
)
|
||||
|
||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
@ -268,6 +268,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
|
||||
E.limit 1
|
||||
return (user E.^. UserSurname)
|
||||
)
|
||||
, ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "term"
|
||||
@ -515,7 +518,7 @@ postCorrectionsR = do
|
||||
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
|
||||
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
|
||||
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
||||
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime)
|
||||
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime)
|
||||
]
|
||||
courseOptions = runDB $ do
|
||||
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||
@ -531,6 +534,7 @@ postCorrectionsR = do
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictSorting (\name _ -> name /= "corrector")
|
||||
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
||||
& defaultFilter (Map.fromList [("israted",["no","Nein","No","False","Just False"]), ("sheet-search",["foo"])]) -- this does not work. "no" is the form value that we wanted
|
||||
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
||||
[ downloadAction
|
||||
]
|
||||
@ -617,7 +621,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
|
||||
<*> pointsForm
|
||||
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
|
||||
let corrForm = wrapForm corrForm' def
|
||||
let corrForm = wrapForm' BtnSave corrForm' def
|
||||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
, formEncoding = corrEncoding
|
||||
}
|
||||
@ -721,6 +725,7 @@ postCorrectionsUploadR = do
|
||||
, formEncoding = uploadEncoding
|
||||
}
|
||||
|
||||
maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings'
|
||||
|
||||
defaultLayout $ do
|
||||
let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions")
|
||||
@ -878,8 +883,8 @@ postCorrectionsGradeR = do
|
||||
uid <- requireAuthId
|
||||
let whereClause = ratedBy uid
|
||||
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
||||
[ dbRow
|
||||
, colSchool
|
||||
[ -- dbRow,
|
||||
colSchool
|
||||
, colTerm
|
||||
, colCourse
|
||||
, colSheet
|
||||
@ -947,9 +952,10 @@ postSAssignR tid ssh csh shn cID = do
|
||||
]
|
||||
addMessageI Success MsgCorrectorUpdated
|
||||
redirect actionUrl
|
||||
let corrForm = wrapForm corrForm' def
|
||||
let corrForm = wrapForm' BtnSave corrForm' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = corrEncoding
|
||||
, formSubmit = FormDualSubmit
|
||||
}
|
||||
defaultLayout $ do
|
||||
setTitleI MsgCorrectorAssignTitle
|
||||
|
||||
@ -40,7 +40,12 @@ import Jobs.Queue
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
|
||||
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
||||
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
|
||||
@ -280,7 +285,7 @@ getTermCourseListR tid = do
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors) <- runDB . maybeT notFound $ do
|
||||
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- runDB . maybeT notFound $ do
|
||||
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
|
||||
<- lift . E.select . E.from $
|
||||
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
|
||||
@ -312,7 +317,13 @@ getCShowR tid ssh csh = do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
||||
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
||||
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors)
|
||||
tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
||||
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
||||
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors)
|
||||
|
||||
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
@ -336,16 +347,16 @@ getCShowR tid ssh csh = do
|
||||
dbtProj = return
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> textCell (CI.original tutorialName)
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
|
||||
tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
||||
return [whamlet|
|
||||
$newline never
|
||||
<ul .list--iconless .list--inline .list--comma-separated>
|
||||
$forall tutor <- tutors
|
||||
$forall tutor <- tutTutors
|
||||
<li>
|
||||
^{nameEmailWidget' tutor}
|
||||
|]
|
||||
@ -417,8 +428,8 @@ registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegist
|
||||
Nothing -> return (Nothing,Nothing)
|
||||
Just _ -> bimap Just Just <$> case participant of
|
||||
Just CourseParticipant{courseParticipantField=Just sfid}
|
||||
-> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
|
||||
_other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature
|
||||
-> mforced (studyFeaturesPrimaryFieldFor False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
|
||||
_other -> mreq (studyFeaturesPrimaryFieldFor False [ ] loggedin) (fslI MsgCourseStudyFeature
|
||||
& setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
|
||||
-- button de-/register
|
||||
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
|
||||
@ -686,14 +697,14 @@ instance FromJSON (InvitationDBData Lecturer) where
|
||||
|
||||
instance ToJSON (InvitationTokenData Lecturer) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData Lecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
lecturerInvitationConfig :: InvitationConfig Lecturer
|
||||
lecturerInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
@ -704,7 +715,7 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of
|
||||
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
|
||||
Nothing -> areq (selectField optionsFinite) lFs Nothing
|
||||
Just lType -> aforced (selectField optionsFinite) lFs lType
|
||||
where
|
||||
@ -802,7 +813,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: ListLength -- ^ Current shape
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
@ -1134,7 +1145,7 @@ postCUsersR tid ssh csh = do
|
||||
, colUserDegreeShort
|
||||
, colUserField
|
||||
, colUserSemester
|
||||
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
|
||||
, sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
|
||||
, colUserComment tid ssh csh
|
||||
]
|
||||
psValidator = def & defaultSortingByName
|
||||
@ -1219,11 +1230,11 @@ postCUserR tid ssh csh uCId = do
|
||||
dozentId <- requireAuthId
|
||||
uid <- decrypt uCId
|
||||
-- DB reads
|
||||
(cid, User{..}, registration, thisUniqueNote, noteText, noteEdits, studies ) <- runDB $ do
|
||||
(cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- Abfrage Benutzerdaten
|
||||
user <- get404 uid
|
||||
registration <- fmap entityVal <$> getBy (UniqueParticipant uid cid)
|
||||
registration <- getBy (UniqueParticipant uid cid)
|
||||
-- Abfrage Teilnehmernotiz
|
||||
let thisUniqueNote = UniqueCourseUserNote uid cid
|
||||
mbNoteEnt <- getBy thisUniqueNote
|
||||
@ -1243,8 +1254,7 @@ postCUserR tid ssh csh uCId = do
|
||||
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||
return (studyfeat, studydegree, studyterms)
|
||||
|
||||
return (cid,user,registration,thisUniqueNote,noteText,noteEdits,studies)
|
||||
return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
|
||||
let editByWgt = [whamlet|
|
||||
$forall (etime,_eemail,ename,_esurname) <- noteEdits
|
||||
<br>
|
||||
@ -1253,36 +1263,93 @@ postCUserR tid ssh csh uCId = do
|
||||
|
||||
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
|
||||
aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
|
||||
<* saveButton
|
||||
formResult noteRes $ \mbNote -> (do
|
||||
let noteFrag :: Text
|
||||
noteFrag = "notes"
|
||||
noteWidget = wrapForm noteView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: noteFrag
|
||||
, formEncoding = noteEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just noteFrag
|
||||
}
|
||||
formResult noteRes $ \mbNote -> do
|
||||
now <- liftIO getCurrentTime
|
||||
case mbNote of
|
||||
runDB $ case mbNote of
|
||||
Nothing -> do
|
||||
runDB $ do
|
||||
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
|
||||
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
|
||||
deleteBy thisUniqueNote
|
||||
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
|
||||
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
|
||||
deleteBy thisUniqueNote
|
||||
addMessageI Info MsgCourseUserNoteDeleted
|
||||
redirect currentRoute -- reload page after post
|
||||
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return() -- no changes
|
||||
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
|
||||
(Just note) -> do
|
||||
runDB $ do
|
||||
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
|
||||
void . insert $ CourseUserNoteEdit dozentId now noteKey
|
||||
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
|
||||
void . insert $ CourseUserNoteEdit dozentId now noteKey
|
||||
addMessageI Success MsgCourseUserNoteSaved
|
||||
redirect currentRoute -- reload page after post
|
||||
)
|
||||
-- De-/Register Button for Lecturer
|
||||
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
||||
((registerRes,registerView), registerEnctype) <- runFormPost $ registerForm (Just uid) registration Nothing Nothing -- Lecturers are never asked their own register secret
|
||||
formResult registerRes $ \(mbSfId, _secretCorrect) -> if -- lecturers need no secret verification
|
||||
| isJust registration -> do
|
||||
runDB $ deleteBy $ UniqueParticipant uid cid
|
||||
redirect $ currentRoute :#: noteFrag -- reload page after post
|
||||
|
||||
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
|
||||
let currentField :: Maybe (Maybe StudyFeaturesId)
|
||||
currentField = courseParticipantField . entityVal <$> mRegistration
|
||||
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
|
||||
|
||||
let registrationFieldFrag :: Text
|
||||
registrationFieldFrag = "registration-field"
|
||||
regFieldWidget = wrapForm regFieldView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
|
||||
, formEncoding = regFieldEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormAutoSubmit
|
||||
, formAnchor = Just registrationFieldFrag
|
||||
}
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
|
||||
formResult regFieldRes $ \courseParticipantField' -> do
|
||||
runDB $ do
|
||||
update pId [ CourseParticipantField =. courseParticipantField' ]
|
||||
addMessageI Success MsgCourseStudyFeatureUpdated
|
||||
redirect $ currentRoute :#: registrationFieldFrag
|
||||
|
||||
let regButton
|
||||
| Just _ <- mRegistration = BtnDeregister
|
||||
| otherwise = BtnRegister
|
||||
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
|
||||
|
||||
let registrationButtonFrag :: Text
|
||||
registrationButtonFrag = "registration-button"
|
||||
regButtonWidget = wrapForm regButtonView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
|
||||
, formEncoding = regButtonEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAnchor = Just registrationButtonFrag
|
||||
}
|
||||
formResult regButtonRes $ \case
|
||||
BtnDeregister
|
||||
| Just (Entity pId _) <- mRegistration
|
||||
-> do
|
||||
runDB $ delete pId
|
||||
addMessageI Info MsgCourseDeregisterOk
|
||||
| otherwise -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
regOk <- runDB $ insertUnique $ CourseParticipant cid uid actTime mbSfId
|
||||
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
| otherwise
|
||||
-> invalidArgs ["User not registered"]
|
||||
BtnRegister -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let primaryField
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
|
||||
= Just featId
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
|
||||
case pId of
|
||||
Just _ -> do
|
||||
addMessageI Success MsgCourseRegisterOk
|
||||
redirect currentRoute
|
||||
Nothing -> invalidArgs ["User already registered"]
|
||||
|
||||
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
|
||||
|
||||
-- generate output
|
||||
let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|]
|
||||
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
|
||||
@ -1298,8 +1365,9 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
|
||||
-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
|
||||
-- If they are shared, adjust MsgCourseUserNoteTooltip
|
||||
getCNotesR = error "CNotesR: Not implemented"
|
||||
postCNotesR = error "CNotesR: Not implemented"
|
||||
getCNotesR = postCNotesR
|
||||
postCNotesR _ _ _ = do
|
||||
defaultLayout $ [whamlet|You have corrector access to this course.|]
|
||||
|
||||
|
||||
getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -1340,6 +1408,7 @@ postCCommR tid ssh csh = do
|
||||
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
|
||||
return user
|
||||
)
|
||||
, ( RGCourseTutors
|
||||
@ -1347,6 +1416,7 @@ postCCommR tid ssh csh = do
|
||||
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
|
||||
return user
|
||||
)
|
||||
]
|
||||
@ -1355,7 +1425,155 @@ postCCommR tid ssh csh = do
|
||||
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
||||
}
|
||||
|
||||
|
||||
|
||||
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCLecInviteR = postCLecInviteR
|
||||
postCLecInviteR = invitationR lecturerInvitationConfig
|
||||
|
||||
|
||||
|
||||
-- Invitations for ordinary participants of this course
|
||||
instance IsInvitableJunction CourseParticipant where
|
||||
type InvitationFor CourseParticipant = Course
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantFild :: Maybe StudyFeaturesId
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- no data needed in DB to manage participant invitation
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData CourseParticipant = InvTokenDataParticipant
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
|
||||
|
||||
ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ()))
|
||||
|
||||
instance ToJSON (InvitableJunction CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToJSON (InvitationTokenData CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
participantInvitationConfig :: InvitationConfig CourseParticipant
|
||||
participantInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
||||
-- Keine besonderen Einschränkungen beim Einlösen der Token
|
||||
-- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden!
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
|
||||
return $ JunctionParticipant <$> pure now <*> studyFeatures
|
||||
invitationSuccessMsg Course{..} _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurSuccess :: [UserEmail]
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCAddUserR = postCAddUserR
|
||||
postCAddUserR tid ssh csh = do
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
|
||||
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
||||
(fslI MsgCourseParticipantInviteField) Nothing
|
||||
|
||||
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
wrapForm formWgt def
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
}
|
||||
where
|
||||
processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
|
||||
processUsers cid users = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do
|
||||
-- send Invitation eMails to unkown users
|
||||
sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
||||
-- register known users
|
||||
execWriterT $ mapM (registerUser cid) uids
|
||||
|
||||
when (not $ null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
|
||||
when (not $ null alreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null registeredNoField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null registeredOneField) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField
|
||||
|
||||
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid uid = exceptT tell tell $ do
|
||||
User{..} <- lift . lift $ getJust uid
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
|
||||
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features = Just f
|
||||
| otherwise = Nothing
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, ..
|
||||
}
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
|
||||
|
||||
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCInviteR = postCInviteR
|
||||
postCInviteR = invitationR participantInvitationConfig
|
||||
|
||||
@ -9,6 +9,7 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Conduit.List as C
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -23,8 +24,6 @@ import Handler.Utils.Table.Columns
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
|
||||
|
||||
|
||||
|
||||
data MaterialForm = MaterialForm
|
||||
{ mfName :: MaterialName
|
||||
, mfType :: Maybe Text
|
||||
@ -72,6 +71,11 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
<*> aopt (multiFileField oldFileIds)
|
||||
(fslI MsgMaterialFiles) (mfFiles <$> template)
|
||||
|
||||
getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material)
|
||||
getMaterialKeyBy404 tid ssh csh mnm = do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
getKeyBy404 $ UniqueMaterial cid mnm
|
||||
|
||||
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
|
||||
fetchMaterial tid ssh csh mnm = do
|
||||
[matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints
|
||||
@ -90,6 +94,9 @@ getMaterialListR tid ssh csh = do
|
||||
let matLink :: MaterialName -> Route UniWorX
|
||||
matLink = CourseR tid ssh csh . flip MaterialR MShowR
|
||||
|
||||
filesLink :: MaterialName -> Route UniWorX
|
||||
filesLink = CourseR tid ssh csh . flip MaterialR MArchiveR
|
||||
|
||||
materialModDateCell :: IsDBTable m a => Material -> DBCell m a
|
||||
materialModDateCell Material{materialVisibleFrom, materialLastEdit}
|
||||
| NTop materialVisibleFrom >= NTop (Just materialLastEdit)
|
||||
@ -113,13 +120,15 @@ getMaterialListR tid ssh csh = do
|
||||
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
|
||||
, dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
|
||||
, dbtColonnade = widgetColonnade $ mconcat
|
||||
[ dbRow
|
||||
, sortable (Just "type") (i18nCell MsgMaterialType)
|
||||
[ -- dbRow,
|
||||
sortable (Just "type") (i18nCell MsgMaterialType)
|
||||
$ foldMap textCell . materialType . row2material
|
||||
, sortable (Just "name") (i18nCell MsgMaterialName)
|
||||
$ liftA2 anchorCell matLink toWgt . materialName . row2material
|
||||
, sortable (toNothingS "description") mempty
|
||||
$ foldMap modalCell . materialDescription . row2material
|
||||
, sortable (toNothingS "zip-archive") mempty -- TODO: don't show if there are no files!
|
||||
$ fileCell . filesLink . materialName . row2material
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
|
||||
, sortable (Just "last-edit") (i18nCell MsgFileModified)
|
||||
@ -170,13 +179,16 @@ getMShowR tid ssh csh mnm = do
|
||||
let matLink :: FilePath -> Route UniWorX
|
||||
matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
|
||||
|
||||
seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
|
||||
zipLink :: Route UniWorX
|
||||
zipLink = CMaterialR tid ssh csh mnm MZipR
|
||||
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
( Entity _mid material@Material{materialType, materialDescription}
|
||||
, (Any hasFiles,fileTable)) <- runDB $ do
|
||||
matEnt <- fetchMaterial tid ssh csh mnm
|
||||
let materialModDateCell :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
|
||||
materialModDateCell = if seeAllModificationTimestamps
|
||||
let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
|
||||
materialModDateCol = if seeAllModificationTimestamps
|
||||
then colFileModification
|
||||
else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt)
|
||||
let psValidator = def & defaultSortingByFileTitle
|
||||
@ -190,7 +202,7 @@ getMShowR tid ssh csh mnm = do
|
||||
, dbtColonnade = widgetColonnade $ mconcat
|
||||
[ dbRowIndicator -- important: contains writer to indicate that the tables is not empty
|
||||
, colFilePathSimple (view $ _dbrOutput . _1) matLink
|
||||
, materialModDateCell (view $ _dbrOutput . _2)
|
||||
, materialModDateCol (view $ _dbrOutput . _2)
|
||||
]
|
||||
, dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr
|
||||
, dbtStyle = def
|
||||
@ -255,6 +267,7 @@ postMaterialNewR tid ssh csh = do
|
||||
siteLayoutMsg headingLong $ do
|
||||
setTitleI headingShort
|
||||
editWidget
|
||||
$(i18nWidgetFile "html-input")
|
||||
|
||||
handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget
|
||||
handleMaterialEdit tid ssh csh cid template dbMaterial = do
|
||||
@ -337,3 +350,35 @@ postMDelR tid ssh csh mnm = do
|
||||
, drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR
|
||||
, drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
|
||||
}
|
||||
|
||||
-- | Variant of getMArchiveR that always serves a Zip Archive, even for single files. Kept, since we might change this according to UX feedback.
|
||||
getMZipR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
|
||||
getMZipR tid ssh csh mnm = do
|
||||
let filename = ZIPArchiveName mnm
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
|
||||
respondSourceDB "application/zip" $ do
|
||||
mid <- lift $ getMaterialKeyBy404 tid ssh csh mnm
|
||||
-- Entity{entityKey=mid, entityVal=material} <- lift $ fetchMaterial tid ssh csh mnm
|
||||
let
|
||||
fileSelect = E.selectSource . E.from $ \(materialFile `E.InnerJoin` file) -> do
|
||||
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
|
||||
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
|
||||
return file
|
||||
zipComment = Text.encodeUtf8 $ termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> ":" <> mnm)
|
||||
fileSelect .| C.map entityVal .| produceZip ZipInfo{..} .| C.map toFlushBuilder
|
||||
|
||||
-- | Variant of getMZipR that does not serve single file Zip Archives. Maybe confusing to users.
|
||||
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
|
||||
getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery
|
||||
where
|
||||
archivename = termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)
|
||||
getMatQuery = E.select . E.from $
|
||||
\(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
|
||||
E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile
|
||||
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
|
||||
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. material E.^. MaterialName E.==. E.val mnm
|
||||
return file
|
||||
|
||||
@ -127,7 +127,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
| errorMsgs <- validateSheet mr sheetResult
|
||||
@ -163,6 +163,14 @@ getSheetListR tid ssh csh = do
|
||||
now <- liftIO getCurrentTime
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
|
||||
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
|
||||
= [ sft | sft <- [minBound..maxBound]
|
||||
, sft /= SheetExercise || hasExercise
|
||||
, sft /= SheetHint || hasHint
|
||||
, sft /= SheetSolution || hasSolution
|
||||
, sft /= SheetMarking || hasMarking
|
||||
]
|
||||
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||
@ -178,21 +186,32 @@ getSheetListR tid ssh csh = do
|
||||
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
|
||||
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ dbRow
|
||||
, sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
[ -- dbRow ,
|
||||
sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
||||
, sortable (toNothing "downloads") (i18nCell MsgFiles)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> mconcat
|
||||
[ icnCell & addIconFixedWidth
|
||||
| let existingSFTs = hasSFT existFiles
|
||||
, sft <- [minBound..maxBound]
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR $ ZIPArchiveName sft
|
||||
, let icn = toWidget $ sheetFile2markup sft
|
||||
, let icnCell = if sft `elem` existingSFTs
|
||||
then linkEmptyCell link icn
|
||||
else spacerCell
|
||||
]
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveFrom
|
||||
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveTo
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveTo
|
||||
, sortable Nothing (i18nCell MsgSheetType)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
@ -201,7 +220,7 @@ getSheetListR tid ssh csh = do
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} ->
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
|
||||
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
|
||||
case mbSub of
|
||||
Nothing -> cellTell mempty $ stats Nothing
|
||||
@ -216,7 +235,7 @@ getSheetListR tid ssh csh = do
|
||||
|
||||
, sortable Nothing -- (Just "percent")
|
||||
(i18nCell MsgRatingPercent)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub,_)} -> case mbSub of
|
||||
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
|
||||
case preview (_grading . _maxPoints) sType of
|
||||
Just maxPoints
|
||||
@ -228,14 +247,21 @@ getSheetListR tid ssh csh = do
|
||||
]
|
||||
|
||||
psValidator = def
|
||||
& defaultSorting [SortDescBy "submission-since"]
|
||||
& defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
|
||||
|
||||
(raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
|
||||
{ dbtColonnade = sheetCol
|
||||
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
|
||||
-> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
|
||||
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
|
||||
sheetData dt
|
||||
let existFiles = -- check whether files exist for given type
|
||||
( hasSheetFileQuery sheet SheetExercise
|
||||
, hasSheetFileQuery sheet SheetHint
|
||||
, hasSheetFileQuery sheet SheetSolution
|
||||
, hasSheetFileQuery sheet SheetMarking
|
||||
)
|
||||
return (sheet, lastSheetEdit sheet, submission, existFiles)
|
||||
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
|
||||
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _, _) }
|
||||
-> dbr <$ guardM (lift $ sheetFilter sheetName)
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "name"
|
||||
@ -298,18 +324,18 @@ getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid ssh csh shn = do
|
||||
now <- liftIO getCurrentTime
|
||||
Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
|
||||
-- without Colonnade
|
||||
-- fileNameTypes <- runDB $ E.select $ E.from $
|
||||
-- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- -- Restrict to consistent rows that correspond to each other
|
||||
-- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
-- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
-- -- filter to requested file
|
||||
-- E.where_ (sheet E.^. SheetId E.==. E.val sid )
|
||||
-- -- return desired columns
|
||||
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
|
||||
-- with Colonnade
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
|
||||
sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
|
||||
= dateTimeCellVisible now dts
|
||||
| otherwise = isVisibleCell False
|
||||
|
||||
sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a
|
||||
sftModification sft mtime
|
||||
| seeAllModificationTimestamps = dateTimeCell mtime
|
||||
| NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime
|
||||
| otherwise = mempty
|
||||
|
||||
let fileData (sheetFile `E.InnerJoin` file) = do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
@ -321,12 +347,15 @@ getSShowR tid ssh csh shn = do
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(str2widget fName)
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
|
||||
$ \(_, _ , E.Value ftype) -> sftVisible ftype
|
||||
, sortable (Just "time") (i18nCell MsgFileModified)
|
||||
$ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified
|
||||
-- , colFileModification (view _2)
|
||||
, sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCellVisible now modified
|
||||
]
|
||||
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
@ -346,6 +375,9 @@ getSShowR tid ssh csh shn = do
|
||||
, ( "path"
|
||||
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
|
||||
)
|
||||
-- , ( "visible"
|
||||
-- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
|
||||
-- )
|
||||
, ( "time"
|
||||
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
||||
)
|
||||
@ -406,24 +438,12 @@ postSPseudonymR tid ssh csh shn = do
|
||||
|
||||
|
||||
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid ssh csh shn typ title = serveOneFile fileQuery
|
||||
where
|
||||
fileQuery = E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
||||
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
)
|
||||
-- return file entity
|
||||
return file
|
||||
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file
|
||||
|
||||
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent
|
||||
getSZipR tid ssh csh shn filename@(ZIPArchiveName sft)
|
||||
= serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft
|
||||
|
||||
|
||||
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid ssh csh = do
|
||||
@ -706,7 +726,7 @@ correctorForm shid = wFormToAForm $ do
|
||||
return (res, $(widgetFile "sheetCorrectors/cell"))
|
||||
|
||||
|
||||
miDelete :: ListLength
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId)
|
||||
-> ListPosition
|
||||
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
@ -815,14 +835,14 @@ instance FromJSON (InvitationDBData SheetCorrector) where
|
||||
|
||||
instance ToJSON (InvitationTokenData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
correctorInvitationConfig :: InvitationConfig SheetCorrector
|
||||
correctorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Sheet{..} _ = do
|
||||
invitationRoute (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
|
||||
invitationResolveFor = do
|
||||
@ -837,7 +857,7 @@ correctorInvitationConfig = InvitationConfig{..}
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state
|
||||
invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state
|
||||
invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest Sheet{..} _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
@ -846,3 +866,10 @@ correctorInvitationConfig = InvitationConfig{..}
|
||||
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSCorrInviteR = postSCorrInviteR
|
||||
postSCorrInviteR = invitationR correctorInvitationConfig
|
||||
|
||||
|
||||
getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet!
|
||||
getSIsCorrR _ _ _ shn = do
|
||||
defaultLayout $ [whamlet|You have corrector access to #{shn}.|]
|
||||
|
||||
|
||||
@ -1,17 +1,21 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Submission where
|
||||
|
||||
import Import
|
||||
|
||||
import Jobs
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import Network.Mime
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
-- import Control.Monad.Trans.Maybe
|
||||
-- import Control.Monad.State.Class
|
||||
@ -22,9 +26,6 @@ import Data.Maybe (fromJust)
|
||||
-- import qualified Data.Maybe
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
|
||||
|
||||
@ -33,12 +34,16 @@ import qualified Data.Conduit.List as Conduit
|
||||
|
||||
-- import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import Data.Map (Map, (!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
-- import Data.Bifunctor
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
-- import Colonnade hiding (bool, fromMaybe)
|
||||
-- import qualified Yesod.Colonnade as Yesod
|
||||
-- import qualified Text.Blaze.Html5.Attributes as HA
|
||||
@ -48,30 +53,207 @@ import System.FilePath
|
||||
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
|
||||
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
|
||||
let
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload -> pure Nothing
|
||||
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> fileUploadForm
|
||||
<*> ( (:|)
|
||||
-- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
|
||||
<$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
| g <- [2..(fromIntegral groupNr)]
|
||||
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
||||
])
|
||||
)
|
||||
where
|
||||
(groupNr, editableBuddies)
|
||||
| Arbitrary{..} <- grouping = (maxParticipants, True)
|
||||
| RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
|
||||
| otherwise = (0, False)
|
||||
instance IsInvitableJunction SubmissionUser where
|
||||
type InvitationFor SubmissionUser = Submission
|
||||
data InvitableJunction SubmissionUser = JunctionSubmissionUser
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData SubmissionUser = InvDBDataSubmissionUser
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser))
|
||||
(\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..})
|
||||
|
||||
instance ToJSON (InvitableJunction SubmissionUser) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction SubmissionUser) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData SubmissionUser) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData SubmissionUser) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToJSON (InvitationTokenData SubmissionUser) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData SubmissionUser) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
submissionUserInvitationConfig :: InvitationConfig SubmissionUser
|
||||
submissionUserInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity subId Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
cID <- encrypt subId
|
||||
return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
|
||||
subId <- decrypt cID
|
||||
bool notFound (return subId) =<< existsKey subId
|
||||
invitationSubject Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
|
||||
invitationTokenConfig Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
|
||||
let itExpiresAt = Nothing
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure JunctionSubmissionUser
|
||||
invitationSuccessMsg Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
|
||||
invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
cID <- encrypt submissionUserSubmission
|
||||
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
|
||||
|
||||
|
||||
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
|
||||
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
|
||||
<$> fileUploadForm
|
||||
<*> wFormToAForm submittorsForm
|
||||
where
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload
|
||||
-> pure Nothing
|
||||
(Upload unpackZips)
|
||||
-> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
|
||||
miCell' :: Markup -> Either UserEmail UserId -> Widget
|
||||
miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
|
||||
miCell' csrf (Right uid) = do
|
||||
User{..} <- liftHandlerT . runDB $ getJust uid
|
||||
$(widgetFile "widgets/massinput/submissionUsers/cellKnown")
|
||||
|
||||
miLayout :: ListLength
|
||||
-> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state
|
||||
-> Map ListPosition Widget -- ^ Cell widgets
|
||||
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
||||
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "submittors"
|
||||
|
||||
courseUsers :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do
|
||||
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return user
|
||||
|
||||
addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Bool -> Field m (Set (Either UserEmail UserId))
|
||||
addField isAdmin = multiUserField True $ courseUsers <$ guard isAdmin
|
||||
|
||||
addFieldSettings, submittorSettings, singleSubSettings :: FieldSettings UniWorX
|
||||
addFieldSettings = fslI MsgSubmissionMembers
|
||||
submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip
|
||||
singleSubSettings = fslI MsgSubmissionMember
|
||||
|
||||
maxSize | Arbitrary{..} <- grouping = Just maxParticipants
|
||||
| otherwise = Nothing
|
||||
mayEdit = is _Arbitrary grouping
|
||||
|
||||
submittorSettings'
|
||||
| maxSize > Just 1 = submittorSettings
|
||||
| otherwise = singleSubSettings
|
||||
|
||||
miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
|
||||
|
||||
submittorsForm
|
||||
| isLecturer = do-- Form is being used by lecturer; allow Everything™
|
||||
let
|
||||
miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
||||
miAdd nudge btn csrf = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
(addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing
|
||||
let addRes' = addRes <&> \newData oldData -> if
|
||||
| existing <- newData `Set.intersection` Set.fromList oldData
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgSubmissionUserAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess $ Set.toList newData
|
||||
return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
|
||||
|
||||
mRoute <- getCurrentRoute
|
||||
submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers)
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return $ submittors >>= \submittors' -> if
|
||||
| null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
|
||||
| otherwise -> FormSuccess $ Set.fromList submittors'
|
||||
| otherwise = do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
mRoute <- getCurrentRoute
|
||||
|
||||
let
|
||||
miAdd :: ListPosition
|
||||
-> Natural
|
||||
-> (Text -> Text)
|
||||
-> FieldView UniWorX
|
||||
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ nudge btn = Just $ \csrf -> do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
(addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing
|
||||
let addRes' = addRes <&> \newData oldData -> if
|
||||
| existing <- newData `Set.intersection` setOf folded oldData
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgSubmissionUserAlreadyAdded]
|
||||
| otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData
|
||||
in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData
|
||||
return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
|
||||
|
||||
miCell :: ListPosition
|
||||
-> Either UserEmail UserId
|
||||
-> Maybe ()
|
||||
-> (Text -> Text)
|
||||
-> Form ()
|
||||
miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat)
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId)
|
||||
-> ListPosition
|
||||
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
||||
miDelete dat delPos = do
|
||||
guard mayEdit
|
||||
guard $ Map.size dat > 1
|
||||
|
||||
-- User may drop from submission only if it already exists; no directly creating submissions for other people
|
||||
guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid
|
||||
|
||||
miDeleteList dat delPos
|
||||
|
||||
miAllowAdd :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Bool
|
||||
miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize
|
||||
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction = miButtonAction' mRoute
|
||||
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
|
||||
postProcess = setOf $ folded . _1
|
||||
fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers)
|
||||
|
||||
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
||||
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
|
||||
|
||||
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionNewR = postSubmissionNewR
|
||||
@ -100,13 +282,14 @@ getSubmissionOwnR tid ssh csh shn = do
|
||||
|
||||
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
|
||||
submissionHelper tid ssh csh shn mcid = do
|
||||
(Entity uid userData) <- requireAuth
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
|
||||
Just actionUrl <- getCurrentRoute
|
||||
|
||||
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
||||
(Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do
|
||||
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
|
||||
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
||||
case msmid of
|
||||
Nothing -> do
|
||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -132,8 +315,8 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return $ user E.^. UserEmail
|
||||
return (csheet, map E.unValue buddies, [])
|
||||
return $ user E.^. UserId
|
||||
return (csheet, Set.fromList $ map (Right . E.unValue) buddies, [], maySubmit, isLecturer, not isLecturer)
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI Info MsgSubmissionAlreadyExists
|
||||
@ -146,15 +329,18 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
invalidArgsI [MsgSubmissionWrongSheet]
|
||||
-- fetch buddies from current submission
|
||||
(Any isOwner, buddies) <- do
|
||||
submitters <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return (user E.^. UserId, user E.^. UserEmail)
|
||||
let breakUserFromBuddies (E.Value userID, E.Value email)
|
||||
| uid == userID = (Any True , [])
|
||||
| otherwise = (Any False, [email])
|
||||
return $ foldMap breakUserFromBuddies submitters
|
||||
return $ user E.^. UserId
|
||||
let breakUserFromBuddies (E.Value userID)
|
||||
| uid == userID = (Any True , mempty )
|
||||
| otherwise = (mempty , Set.singleton $ Right userID)
|
||||
|
||||
invites <- sourceInvitationsList smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
|
||||
|
||||
return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
|
||||
|
||||
lastEdits <- do
|
||||
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
||||
@ -167,38 +353,37 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
else E.nothing
|
||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
return (csheet,buddies,lastEdits)
|
||||
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
|
||||
let formWidget = wrapForm formWidget' def
|
||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
|
||||
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
|
||||
let formWidget = wrapForm' BtnHandIn formWidget' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
|
||||
mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
|
||||
res' <- case res of
|
||||
FormMissing -> return FormMissing
|
||||
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
||||
-- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students)
|
||||
(FormSuccess (mFiles,_submitter:|[])) -> return $ FormSuccess (mFiles,[]) -- Type change
|
||||
(FormSuccess (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members
|
||||
| Arbitrary{..} <- sheetGrouping -> do
|
||||
(FormSuccess res'@(_, groupMembers))
|
||||
| Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
|
||||
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
|
||||
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
|
||||
let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
|
||||
prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
|
||||
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
||||
participants <- fmap prep . E.select . E.from $ \user -> do
|
||||
E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
|
||||
E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds
|
||||
let
|
||||
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
|
||||
isParticipant = E.exists . E.from $ \courseParticipant -> do
|
||||
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
|
||||
return $ E.countRows E.>. E.val (0 :: Int64)
|
||||
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||
hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
||||
case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
|
||||
Nothing -> return ()
|
||||
Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
||||
return $ E.countRows E.>. E.val (0 :: Int64)
|
||||
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
|
||||
|
||||
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
|
||||
@ -207,22 +392,22 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
let
|
||||
failmsgs = (concat :: [[Text]] -> [Text])
|
||||
[ flip Map.foldMapWithKey participants $ \email -> \case
|
||||
Nothing -> pure . mr $ MsgEMailUnknown email
|
||||
-- Nothing -> pure . mr $ MsgEMailUnknown email
|
||||
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
|
||||
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
|
||||
_other -> mempty
|
||||
, case fromIntegral (length participants) `compare` maxParticipants of
|
||||
, case fromIntegral (Map.size participants) `compare` maxParticipants of
|
||||
LT -> mempty
|
||||
_ -> pure $ mr MsgTooManyParticipants
|
||||
]
|
||||
return $ if null failmsgs
|
||||
then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
|
||||
then FormSuccess res'
|
||||
else FormFailure failmsgs
|
||||
| otherwise -> return $ FormFailure ["Mismatching number of group participants"]
|
||||
| otherwise -> return $ FormSuccess res'
|
||||
|
||||
|
||||
case res' of
|
||||
(FormSuccess (mFiles, setFromList -> adhocIds)) -> do
|
||||
(FormSuccess (mFiles, adhocMembers)) -> do
|
||||
smid <- do
|
||||
smid <- case (mFiles, msmid) of
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
@ -238,19 +423,24 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
, submissionRatingAssigned = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
||||
let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
|
||||
-- remove obsolete old entries
|
||||
deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
|
||||
-- maybe add current users
|
||||
forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
|
||||
subUsers <- if
|
||||
| isLecturer -> return adhocMembers
|
||||
| otherwise -> do
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
||||
return $ groupUids `Set.union` adhocMembers
|
||||
let (subEmails, subUids) = partitionEithers $ Set.toList subUsers
|
||||
|
||||
deleteWhere [SubmissionUserSubmission ==. smid]
|
||||
deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails]
|
||||
insertMany_ $ map (flip SubmissionUser smid) subUids
|
||||
sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails
|
||||
return smid
|
||||
cID <- encrypt smid
|
||||
return $ Just cID
|
||||
@ -293,10 +483,12 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle
|
||||
E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission
|
||||
E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId
|
||||
E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False)
|
||||
E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile
|
||||
|
||||
E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate))
|
||||
E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate))
|
||||
E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion))
|
||||
E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid))
|
||||
|
||||
return ((sf1, f1), (sf2, f2))
|
||||
@ -327,6 +519,10 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
|
||||
$(widgetFile "submission")
|
||||
|
||||
getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getSInviteR = postSInviteR
|
||||
postSInviteR = invitationR submissionUserInvitationConfig
|
||||
|
||||
|
||||
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
|
||||
@ -354,10 +550,11 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat
|
||||
return f
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
|
||||
whenM downloadFiles $
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
|
||||
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
|
||||
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
|
||||
other -> do
|
||||
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
|
||||
|
||||
@ -121,7 +121,7 @@ postMessageR cID = do
|
||||
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
|
||||
forms <- traverse (const mkForm) $ () <$ guard maySubmit
|
||||
|
||||
defaultLayout
|
||||
siteLayout' (toWidget <$> summary)
|
||||
$(widgetFile "system-message")
|
||||
where
|
||||
modifySystemMessage smId SystemMessage{..} = do
|
||||
|
||||
@ -49,7 +49,7 @@ getCTutorialListR tid ssh csh = do
|
||||
dbtProj = return . over (_dbrOutput . _2) E.unValue
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialName
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
|
||||
tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
@ -184,6 +184,7 @@ postTCommR tid ssh csh tutn = do
|
||||
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.&&. corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
return user
|
||||
)
|
||||
, ( RGCourseTutors
|
||||
@ -191,12 +192,22 @@ postTCommR tid ssh csh tutn = do
|
||||
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
return user
|
||||
)
|
||||
]
|
||||
, crRecipientAuth = Just $ \uid -> do
|
||||
cID <- encrypt uid
|
||||
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
||||
[E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
|
||||
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
|
||||
E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
|
||||
isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False
|
||||
isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False
|
||||
|
||||
mr <- getMsgRenderer
|
||||
return $ if
|
||||
| isTutorialUser -> Authorized
|
||||
| otherwise -> orAR mr isAssociatedCorrector isAssociatedTutor
|
||||
}
|
||||
|
||||
|
||||
@ -227,14 +238,14 @@ instance FromJSON (InvitationDBData Tutor) where
|
||||
|
||||
instance ToJSON (InvitationTokenData Tutor) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData Tutor) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
tutorInvitationConfig :: InvitationConfig Tutor
|
||||
tutorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Tutorial{..} _ = do
|
||||
invitationRoute (Entity _ Tutorial{..}) _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
|
||||
invitationResolveFor = do
|
||||
@ -249,7 +260,7 @@ tutorInvitationConfig = InvitationConfig{..}
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ = pure JunctionTutor
|
||||
invitationForm _ _ _ = pure JunctionTutor
|
||||
invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
||||
invitationUltDest Tutorial{..} _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
@ -279,7 +290,7 @@ tutorialForm cid template html = do
|
||||
Just cRoute <- getCurrentRoute
|
||||
uid <- liftHandlerT requireAuthId
|
||||
|
||||
let
|
||||
let
|
||||
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
|
||||
where
|
||||
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
||||
@ -306,7 +317,7 @@ tutorialForm cid template html = do
|
||||
|
||||
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
|
||||
|
||||
|
||||
flip (renderAForm FormStandard) html $ TutorialForm
|
||||
<$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
|
||||
<*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
|
||||
@ -345,7 +356,7 @@ getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand ->
|
||||
getCTutorialNewR = postCTutorialNewR
|
||||
postCTutorialNewR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
|
||||
|
||||
formResult newTutResult $ \TutorialForm{..} -> do
|
||||
@ -436,7 +447,7 @@ postTEditR tid ssh csh tutn = do
|
||||
}
|
||||
when (is _Nothing insertRes) $ do
|
||||
let (invites, adds) = partitionEithers $ Set.toList tfTutors
|
||||
|
||||
|
||||
deleteWhere [ TutorTutorial ==. tutid ]
|
||||
insertMany_ $ map (Tutor tutid) adds
|
||||
|
||||
|
||||
@ -7,10 +7,12 @@ import Import
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
-- import qualified Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.CaseInsensitive (original)
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (qRunIO)
|
||||
@ -32,8 +34,6 @@ import Handler.Utils.Mail as Handler.Utils
|
||||
import System.Directory (listDirectory)
|
||||
import System.FilePath.Posix (takeBaseName, takeFileName)
|
||||
|
||||
import Network.Mime
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
@ -56,19 +56,42 @@ serveOneFile query = do
|
||||
| Just fileContent' <- fileContent -> do
|
||||
whenM downloadFiles $
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
| otherwise -> sendResponseStatus noContent204 ()
|
||||
[] -> notFound
|
||||
other -> do
|
||||
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
|
||||
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
|
||||
serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent
|
||||
serveSomeFiles archiveName query = do
|
||||
results <- runDB query
|
||||
case results of
|
||||
[] -> notFound
|
||||
[Entity _fileId File{fileTitle, fileContent}]
|
||||
| Just fileContent' <- fileContent -> do
|
||||
whenM downloadFiles $
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
| otherwise -> sendResponseStatus noContent204 ()
|
||||
files -> do
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|]
|
||||
respondSourceDB "application/zip" $ do
|
||||
let zipComment = T.encodeUtf8 archiveName
|
||||
yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
tidFromText :: Text -> Maybe TermId
|
||||
tidFromText = fmap TermKey . maybeRight . termFromText
|
||||
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
||||
|
||||
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
|
||||
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{lbl}|]
|
||||
|
||||
-- | toWidget-Version of @nameHtml@, for convenience
|
||||
nameWidget :: Text -- ^ userDisplayName
|
||||
-> Text -- ^ userSurname
|
||||
@ -177,7 +200,7 @@ warnTermDays tid times = do
|
||||
i18nWidgetFile :: FilePath -> Q Exp
|
||||
i18nWidgetFile basename = do
|
||||
-- Construct list of available translations (@de@, @en@, ...) at compile time
|
||||
let i18nDirectory = "templates" </> basename
|
||||
let i18nDirectory = "templates" </> "i18n" </> basename
|
||||
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
||||
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
|
||||
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
|
||||
@ -185,7 +208,7 @@ i18nWidgetFile basename = do
|
||||
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
|
||||
ws <- newName "ws" -- Name for dispatch function
|
||||
letE
|
||||
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename </> l) []
|
||||
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
|
||||
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
|
||||
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
|
||||
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
|
||||
|
||||
@ -75,7 +75,7 @@ instance RenderMessage UniWorX RecipientCategory where
|
||||
|
||||
data CommunicationRoute = CommunicationRoute
|
||||
{ crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
|
||||
, crRecipientAuth :: Maybe (UserId -> DB AuthResult)
|
||||
, crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
|
||||
, crJobs :: Communication -> Source (YesodDB UniWorX) Job
|
||||
, crHeading :: SomeMessage UniWorX
|
||||
, crUltDest :: SomeRoute UniWorX
|
||||
@ -91,7 +91,7 @@ data Communication = Communication
|
||||
commR :: CommunicationRoute -> Handler Html
|
||||
commR CommunicationRoute{..} = do
|
||||
cUser <- maybeAuth
|
||||
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
mbCurrentRoute <- getCurrentRoute
|
||||
|
||||
@ -140,7 +140,7 @@ commR CommunicationRoute{..} = do
|
||||
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
|
||||
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
|
||||
return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
|
||||
miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do
|
||||
miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do
|
||||
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
|
||||
return (tickRes, $(widgetFile "widgets/communication/recipientName"))
|
||||
miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
|
||||
@ -162,7 +162,7 @@ commR CommunicationRoute{..} = do
|
||||
hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
|
||||
categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
|
||||
$(widgetFile "widgets/communication/recipientLayout")
|
||||
miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
|
||||
miDelete :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
|
||||
-- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
|
||||
miDelete _ _ = mzero
|
||||
miIdent :: Text
|
||||
@ -172,8 +172,8 @@ commR CommunicationRoute{..} = do
|
||||
|
||||
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
|
||||
<$> recipientAForm
|
||||
<*> aopt textField (fslI MsgCommSubject) Nothing
|
||||
<*> areq htmlField (fslI MsgCommBody) Nothing
|
||||
<*> aopt textField (fslI MsgCommSubject) Nothing
|
||||
<*> areq htmlField (fslpI MsgCommBody "Html") Nothing
|
||||
formResult commRes $ \comm -> do
|
||||
runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
|
||||
addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
|
||||
@ -188,3 +188,4 @@ commR CommunicationRoute{..} = do
|
||||
siteLayoutMsg crHeading $ do
|
||||
setTitleI crHeading
|
||||
formWdgt
|
||||
$(i18nWidgetFile "html-input")
|
||||
|
||||
@ -75,14 +75,27 @@ instance Finite ButtonSave
|
||||
saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m ()
|
||||
saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) ""
|
||||
|
||||
|
||||
|
||||
nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonSave id
|
||||
instance Button UniWorX ButtonSave where
|
||||
btnClasses BtnSave = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
|
||||
data ButtonHandIn = BtnHandIn
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonHandIn
|
||||
instance Finite ButtonHandIn
|
||||
|
||||
nullaryPathPiece ''ButtonHandIn $ camelToPathPiece' 1
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonHandIn id
|
||||
instance Button UniWorX ButtonHandIn where
|
||||
btnClasses BtnHandIn = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
|
||||
data ButtonRegister = BtnRegister | BtnDeregister
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonRegister
|
||||
@ -190,7 +203,7 @@ multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq
|
||||
-> (Html -> MForm Handler (FormResult a, Widget))
|
||||
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
|
||||
|
||||
|
||||
|
||||
------------
|
||||
-- Fields --
|
||||
------------
|
||||
@ -287,8 +300,9 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
||||
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
||||
|
||||
-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
|
||||
studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
|
||||
studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
|
||||
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
||||
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
|
||||
studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
|
||||
-- we need a join, so we cannot just use optionsPersistCryptoId
|
||||
rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
|
||||
E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId
|
||||
@ -316,12 +330,15 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
|
||||
|
||||
nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)]
|
||||
nonEmptyOptions emptyOpt opts
|
||||
| null opts = [ Option
|
||||
| null opts = pure nullOption
|
||||
| isOptional = nullOption : opts
|
||||
| otherwise = opts
|
||||
where
|
||||
nullOption = Option
|
||||
{ optionDisplay = emptyOpt
|
||||
, optionInternalValue = Nothing
|
||||
, optionExternalValue = "NoPrimaryStudyField"
|
||||
} ]
|
||||
| otherwise = opts
|
||||
}
|
||||
|
||||
|
||||
uploadModeField :: Field Handler UploadMode
|
||||
@ -545,7 +562,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel
|
||||
LTUUnique{_ltuResult} -> Right _ltuResult
|
||||
LTUNone{} -> Left MsgIllDefinedUTCTime
|
||||
LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
|
||||
|
||||
|
||||
|
||||
langField :: Bool -- ^ Only allow values from `appLanguages`
|
||||
-> Field (HandlerT UniWorX IO) Lang
|
||||
@ -699,7 +716,7 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
lookupExpr
|
||||
| onlySuggested = suggestions
|
||||
| otherwise = Just $ E.from return
|
||||
|
||||
|
||||
fieldEnctype = UrlEncoded
|
||||
fieldView theId name attrs val isReq = do
|
||||
val' <- case val of
|
||||
@ -719,7 +736,7 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
return $ emails ++ rEmails
|
||||
|
||||
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
|
||||
|
||||
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|
||||
@ -735,7 +752,7 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
$forall email <- suggestedEmails
|
||||
<option value=#{email}>
|
||||
|]
|
||||
fieldParse (all Text.null -> True) _ = return $ Right Nothing
|
||||
fieldParse (all Text.null -> True) _ = return $ Right Nothing
|
||||
fieldParse ts _ = runExceptT . fmap Just $ do
|
||||
let ts' = concatMap (Text.splitOn ",") ts
|
||||
emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
|
||||
|
||||
@ -8,7 +8,7 @@ module Handler.Utils.Form.MassInput
|
||||
, module Handler.Utils.Form.MassInput.Liveliness
|
||||
, massInputA, massInputW
|
||||
, massInputList
|
||||
, massInputAccum, massInputAccumA
|
||||
, massInputAccum, massInputAccumA, massInputAccumW
|
||||
, ListLength(..), ListPosition(..), miDeleteList
|
||||
, EnumLiveliness(..), EnumPosition(..)
|
||||
, MapLiveliness(..)
|
||||
@ -21,7 +21,7 @@ import Handler.Utils.Form (secretJsonField)
|
||||
import Handler.Utils.Form.MassInput.Liveliness
|
||||
import Handler.Utils.Form.MassInput.TH
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Algebra.Lattice hiding (join)
|
||||
|
||||
@ -144,10 +144,11 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
|
||||
|
||||
|
||||
|
||||
miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
|
||||
miDeleteList l pos
|
||||
miDeleteList :: Applicative m => Map ListPosition a -> ListPosition -> m (Map ListPosition ListPosition)
|
||||
miDeleteList dat pos
|
||||
-- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
||||
| l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
|
||||
| Just l <- preview liveCoords $ Map.keysSet dat :: Maybe ListLength
|
||||
, l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
|
||||
| otherwise = pure Map.empty
|
||||
|
||||
data ButtonMassInput coord
|
||||
@ -245,7 +246,7 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i =>
|
||||
-> Maybe cellResult -- Initial result from Argument to @massInput@
|
||||
-> (Text -> Text) -- Nudge deterministic field ids
|
||||
-> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell
|
||||
, miDelete :: liveliness
|
||||
, miDelete :: Map (BoxCoord liveliness) cellData
|
||||
-> BoxCoord liveliness
|
||||
-> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
|
||||
, miAllowAdd :: BoxCoord liveliness
|
||||
@ -349,13 +350,12 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
addedShape <- if
|
||||
| Just s <- addShape -> return s
|
||||
| otherwise -> return sentShape'
|
||||
addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness
|
||||
|
||||
let
|
||||
delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
|
||||
delForm miCoord = do
|
||||
(delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
|
||||
shapeUpdate <- miDelete addedLiveliness miCoord
|
||||
shapeUpdate <- miDelete addedShape miCoord
|
||||
guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
|
||||
return (shapeUpdate <$ assertM (is _Just) delRes, delView)
|
||||
|
||||
@ -423,6 +423,10 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
|
||||
ur <- getUrlRenderParams
|
||||
|
||||
case result of
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml -- Error messages get collected by middleware and added as header to response
|
||||
_other -> return () -- Completely ignore non-error results; we'll short circuit below
|
||||
|
||||
sendResponse $ $(hamletFile "templates/widgets/massinput/massinput-standalone-wrapper.hamlet") ur
|
||||
|
||||
let
|
||||
@ -545,6 +549,24 @@ massInputAccumA :: forall handler cellData ident.
|
||||
massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
|
||||
= formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
|
||||
|
||||
massInputAccumW :: forall handler cellData ident.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, MonadLogger handler
|
||||
, ToJSON cellData, FromJSON cellData
|
||||
, PathPiece ident
|
||||
)
|
||||
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
|
||||
-> (cellData -> Widget)
|
||||
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
||||
-> MassInputLayout ListLength cellData ()
|
||||
-> ident
|
||||
-> FieldSettings UniWorX
|
||||
-> Bool
|
||||
-> Maybe [cellData]
|
||||
-> WForm handler (FormResult [cellData])
|
||||
massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
|
||||
= mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
|
||||
|
||||
|
||||
massInputA :: forall handler cellData cellResult liveliness.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
|
||||
@ -48,7 +48,7 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
|
||||
type InvitationFor junction :: *
|
||||
-- | `junction` without `Key User` and `Key (InvitationFor junction)`
|
||||
data InvitableJunction junction :: *
|
||||
|
||||
|
||||
-- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
|
||||
--
|
||||
-- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
|
||||
@ -113,7 +113,7 @@ invRef = toJSON . InvRef @junction
|
||||
--
|
||||
-- It is advisable to define this once per `junction` in a global constant
|
||||
data InvitationConfig junction = InvitationConfig
|
||||
{ invitationRoute :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
|
||||
{ invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
|
||||
-- ^ Which route calls `invitationR` for this kind of invitation?
|
||||
, invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction))
|
||||
-- ^ Monadically resolve `InvitationFor` during `inviteR`
|
||||
@ -129,7 +129,7 @@ data InvitationConfig junction = InvitationConfig
|
||||
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
|
||||
, invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
|
||||
-- ^ Additional restrictions to check before allowing an user to redeem an invitation token
|
||||
, invitationForm :: InvitationFor junction -> InvitationData junction -> AForm (YesodDB UniWorX) (InvitableJunction junction)
|
||||
, invitationForm :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction)
|
||||
-- ^ Assimilate the additional data entered by the redeeming user
|
||||
, invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX)
|
||||
-- ^ What to tell the redeeming user after accepting the invitation
|
||||
@ -158,7 +158,7 @@ $(return [])
|
||||
|
||||
instance ToJSON (InvitationTokenRestriction junction) where
|
||||
toJSON = $(mkToJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
|
||||
|
||||
|
||||
instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction junction) where
|
||||
parseJSON = $(mkParseJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
|
||||
|
||||
@ -198,9 +198,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
|
||||
ur <- getUrlRenderParams
|
||||
|
||||
fRec <- get404 fid
|
||||
|
||||
|
||||
jInviter <- liftHandlerT requireAuthId
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute fRec dat
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat
|
||||
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
@ -284,7 +284,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
iData = review _InvitationData (dbData, itData)
|
||||
guardAuthResult =<< invitationRestriction fRec iData
|
||||
((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
dataRes <- aFormToWForm $ invitationForm fRec iData
|
||||
dataRes <- aFormToWForm $ invitationForm fRec iData invitee
|
||||
btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
|
||||
case btnRes of
|
||||
FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing
|
||||
@ -333,7 +333,7 @@ instance InvitationR (Handler Html) where
|
||||
|
||||
instance InvitationR b => InvitationR (a -> b) where
|
||||
invitationR cfg _ = invitationR cfg
|
||||
|
||||
|
||||
|
||||
-- $procedure
|
||||
--
|
||||
|
||||
@ -16,7 +16,6 @@ import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import System.FilePath (takeBaseName)
|
||||
import Network.Mime (defaultMimeLookup)
|
||||
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
|
||||
@ -66,7 +65,7 @@ addFileDB :: ( MonadMail m
|
||||
addFileDB fId = do
|
||||
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
|
||||
addPart $ do
|
||||
_partType .= decodeUtf8 (defaultMimeLookup fileName)
|
||||
_partType .= decodeUtf8 (mimeLookup fileName)
|
||||
_partEncoding .= Base64
|
||||
_partFilename .= Just fileName
|
||||
_partContent .= LBS.fromStrict fileContent
|
||||
|
||||
@ -7,6 +7,15 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
|
||||
-- | Map sheet file types to their visibily dates of a given sheet, for convenience
|
||||
sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
|
||||
sheetFileTypeDates Sheet{..} = \case
|
||||
SheetExercise -> Just sheetActiveFrom
|
||||
SheetHint -> sheetHintFrom
|
||||
SheetSolution -> sheetSolutionFrom
|
||||
SheetMarking -> Nothing
|
||||
|
||||
|
||||
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||
, E.SqlSelect b a
|
||||
, Typeable a, MonadHandler m, IsPersistBackend backend
|
||||
|
||||
@ -40,7 +40,6 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
import Handler.Utils
|
||||
import qualified Handler.Utils.Rating as Rating (extractRatings)
|
||||
import Handler.Utils.Submission.TH
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -271,9 +270,6 @@ instance Monoid SubmissionSinkState where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
submissionBlacklist :: [Pattern]
|
||||
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
||||
|
||||
filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
|
||||
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
|
||||
filterSubmission = do
|
||||
@ -510,7 +506,6 @@ sinkSubmission userId mExists isUpdate = do
|
||||
-> update submissionId
|
||||
[ SubmissionRatingTime =. Nothing
|
||||
, SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
]
|
||||
| isUpdate
|
||||
|
||||
@ -28,6 +28,10 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
|
||||
----------------
|
||||
-- Special cells
|
||||
|
||||
-- | Display a breakable space
|
||||
spacerCell :: (IsDBTable m a) => DBCell m a
|
||||
spacerCell = cell [whamlet| |]
|
||||
|
||||
tellCell :: (Monoid a, IsDBTable m a) => a -> DBCell m a -> DBCell m a
|
||||
tellCell = flip mappend . writerCell . tell
|
||||
|
||||
@ -64,11 +68,21 @@ ifCell decision cTrue cFalse x
|
||||
| decision x = cTrue x
|
||||
| otherwise = cFalse x
|
||||
|
||||
linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
||||
linkEmptyCell link wgt = linkEitherCell link (wgt,mempty)
|
||||
|
||||
|
||||
-- Recall: for line numbers, use dbRow
|
||||
|
||||
---------------------
|
||||
-- Icon cells
|
||||
|
||||
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
|
||||
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
|
||||
|
||||
iconSpacerCell :: (IsDBTable m a) => DBCell m a
|
||||
iconSpacerCell = mempty & addIconFixedWidth
|
||||
|
||||
-- | Maybe display a tickmark/checkmark icon
|
||||
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
|
||||
tickmarkCell = cell . toWidget . hasTickmark
|
||||
@ -87,6 +101,21 @@ commentCell Nothing = mempty
|
||||
commentCell (Just link) = anchorCell link icon
|
||||
where icon = toWidget $ hasComment True
|
||||
|
||||
-- | whether something is visible or hidden
|
||||
isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
|
||||
isVisibleCell True = cell . toWidget $ isVisible True
|
||||
isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
|
||||
where
|
||||
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
|
||||
|
||||
-- | for simple file downloads
|
||||
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
||||
fileCell route = anchorCell route $ toWidget fileDownload
|
||||
|
||||
-- | for zip-archive downloads
|
||||
zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
||||
zipCell route = anchorCell route $ toWidget zipDownload
|
||||
|
||||
-- | Display an icon that opens a modal upon clicking
|
||||
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
|
||||
modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content)
|
||||
@ -109,7 +138,7 @@ dateTimeCellVisible watershed t
|
||||
| otherwise = cell timeStampWgt
|
||||
where
|
||||
timeStampWgt = formatTimeW SelFormatDateTime t
|
||||
addUrgencyClass = over cellAttrs $ insertAttr "class" $ statusToUrgencyClass Warning
|
||||
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
|
||||
|
||||
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
|
||||
userCell displayName surname = cell $ nameWidget displayName surname
|
||||
|
||||
@ -23,6 +23,7 @@ module Handler.Utils.Table.Pagination
|
||||
, widgetColonnade, formColonnade, dbColonnade
|
||||
, cell, textCell, stringCell, i18nCell
|
||||
, anchorCell, anchorCell', anchorCellM, anchorCellM'
|
||||
, linkEitherCell, linkEitherCellM, linkEitherCellM'
|
||||
, cellTooltip
|
||||
, listCell
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
@ -656,7 +657,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
|
||||
|
||||
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
|
||||
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
|
||||
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
|
||||
return (filterRes', pagesizeRes')
|
||||
|
||||
let
|
||||
@ -863,6 +864,8 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
|
||||
<div .tooltip__content>_{msg}
|
||||
|]
|
||||
|
||||
-- | Always display widget; maybe a link if user is Authorized.
|
||||
-- Also see variant `linkEmptyCell`
|
||||
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
||||
anchorCell = anchorCellM . return
|
||||
|
||||
@ -886,6 +889,25 @@ anchorCellM' xM x2route x2widget = cell $ do
|
||||
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
|
||||
_otherwise -> widget -- don't show prohibited link
|
||||
|
||||
-- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
|
||||
linkEitherCell :: IsDBTable m a => Route UniWorX -> (Widget, Widget) -> DBCell m a
|
||||
linkEitherCell = linkEitherCellM . return
|
||||
|
||||
linkEitherCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> (Widget, Widget) -> DBCell m a
|
||||
linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)
|
||||
|
||||
linkEitherCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget, x -> Widget) -> DBCell m a
|
||||
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
|
||||
x <- xM
|
||||
let route = x2route x
|
||||
widget = x2widgetAuth x
|
||||
widgetUnauth = x2widgetUnauth x
|
||||
authResult <- liftHandlerT $ isAuthorized route False
|
||||
case authResult of
|
||||
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
|
||||
_otherwise -> widgetUnauth -- show alternative widget
|
||||
|
||||
|
||||
|
||||
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
|
||||
listCell xs mkCell = review dbCell . ([], ) $ do
|
||||
|
||||
@ -27,8 +27,8 @@ requireBearerToken = liftHandlerT $ do
|
||||
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
|
||||
return token
|
||||
|
||||
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a)
|
||||
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a)
|
||||
currentTokenRestrictions = runMaybeT $ do
|
||||
token <- MaybeT maybeBearerToken
|
||||
token <- requireBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ preview (_tokenRestrictionIx route) token
|
||||
|
||||
@ -27,8 +27,6 @@ import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
|
||||
|
||||
import Data.List (dropWhileEnd)
|
||||
|
||||
import Network.Mime
|
||||
|
||||
|
||||
instance Default ZipInfo where
|
||||
def = ZipInfo
|
||||
@ -95,12 +93,16 @@ modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
|
||||
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
|
||||
|
||||
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
|
||||
sourceFiles :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
|
||||
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
|
||||
sourceFiles fInfo
|
||||
| mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
|
||||
| otherwise = yieldM $ acceptFile fInfo
|
||||
| mimeType == "application/zip" = do
|
||||
$logInfoS "sourceFiles" "Unpacking ZIP"
|
||||
fileSource fInfo =$= void consumeZip
|
||||
| otherwise = do
|
||||
$logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|]
|
||||
yieldM $ acceptFile fInfo
|
||||
where
|
||||
mimeType = defaultMimeLookup (fileName fInfo)
|
||||
mimeType = mimeLookup $ fileName fInfo
|
||||
|
||||
acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
|
||||
acceptFile fInfo = do
|
||||
|
||||
@ -49,7 +49,7 @@ import GHC.Generics as Import (Generic)
|
||||
import GHC.Exts as Import (IsList)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..))
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
|
||||
23
src/Jobs.hs
23
src/Jobs.hs
@ -99,17 +99,18 @@ handleJobs foundation@UniWorX{..} = do
|
||||
atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
|
||||
|
||||
-- Start cron operation
|
||||
registeredCron <- liftIO newEmptyTMVarIO
|
||||
let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
|
||||
unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
|
||||
unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
|
||||
cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
|
||||
registeredCron' <- atomically $ do
|
||||
registeredCron' <- tryPutTMVar appCronThread cData
|
||||
registeredCron' <$ putTMVar registeredCron registeredCron'
|
||||
when registeredCron' $
|
||||
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
|
||||
writeJobCtlBlock JobCtlDetermineCrontab
|
||||
when (num > 0) $ do
|
||||
registeredCron <- liftIO newEmptyTMVarIO
|
||||
let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
|
||||
unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
|
||||
unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
|
||||
cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
|
||||
registeredCron' <- atomically $ do
|
||||
registeredCron' <- tryPutTMVar appCronThread cData
|
||||
registeredCron' <$ putTMVar registeredCron registeredCron'
|
||||
when registeredCron' $
|
||||
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
|
||||
writeJobCtlBlock JobCtlDetermineCrontab
|
||||
|
||||
stopJobCtl :: MonadIO m => UniWorX -> m ()
|
||||
-- ^ Stop all worker threads currently running
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Model.Migration
|
||||
( migrateAll
|
||||
, requiresMigration
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -23,6 +24,10 @@ import Data.CaseInsensitive (CI)
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
import Control.Monad.Trans.Reader (mapReaderT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Utils (exceptT)
|
||||
|
||||
-- Database versions must follow https://pvp.haskell.org:
|
||||
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
|
||||
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
|
||||
@ -55,16 +60,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
|
||||
migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
|
||||
migrateAll = do
|
||||
$logDebugS "Migration" "Initial migration"
|
||||
mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do
|
||||
-- Manual migrations to go to InitialVersion below:
|
||||
migrateEnableExtension "citext"
|
||||
mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration
|
||||
|
||||
migrateDBVersioning
|
||||
|
||||
$logDebugS "Migration" "Retrieve applied migrations"
|
||||
appliedMigrations <- selectKeysList [] []
|
||||
missingMigrations <- getMissingMigrations
|
||||
let
|
||||
missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
|
||||
doCustomMigration acc desc migration = acc <* do
|
||||
let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
|
||||
$logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|]
|
||||
@ -78,6 +77,43 @@ migrateAll = do
|
||||
$logDebugS "Migration" "Persistent automatic migration"
|
||||
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'
|
||||
|
||||
requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool
|
||||
requiresMigration = mapReaderT (exceptT return return) $ do
|
||||
initial <- getMigration initialMigration
|
||||
when (not $ null initial) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " initial
|
||||
throwError True
|
||||
|
||||
customs <- getMissingMigrations @_ @m
|
||||
when (not $ Map.null customs) $ do
|
||||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||||
throwError True
|
||||
|
||||
automatic <- getMigration migrateAll'
|
||||
when (not $ null automatic) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " automatic
|
||||
throwError True
|
||||
|
||||
return False
|
||||
|
||||
initialMigration :: Migration
|
||||
-- ^ Manual migrations to go to InitialVersion below:
|
||||
initialMigration = do
|
||||
migrateEnableExtension "citext"
|
||||
migrateDBVersioning
|
||||
|
||||
getMissingMigrations :: forall m m'.
|
||||
( MonadLogger m
|
||||
, MonadBaseControl IO m
|
||||
, MonadIO m
|
||||
, MonadIO m'
|
||||
)
|
||||
=> ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ()))
|
||||
getMissingMigrations = do
|
||||
$logDebugS "Migration" "Retrieve applied migrations"
|
||||
appliedMigrations <- selectKeysList [] []
|
||||
return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
|
||||
|
||||
{-
|
||||
Confusion about quotes, from the PostgreSQL Manual:
|
||||
Single quotes for string constants, double quotes for table/column names.
|
||||
|
||||
@ -42,6 +42,7 @@ import Database.Persist.Sql
|
||||
import Web.HttpApiData
|
||||
import Web.PathPieces
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
@ -250,6 +251,12 @@ instance PathPiece SheetFileType where
|
||||
toPathPiece SheetMarking = "marking"
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
sheetFile2markup :: SheetFileType -> Markup
|
||||
sheetFile2markup SheetExercise = iconQuestion
|
||||
sheetFile2markup SheetHint = iconHint
|
||||
sheetFile2markup SheetSolution = iconSolution
|
||||
sheetFile2markup SheetMarking = iconMarking
|
||||
|
||||
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
|
||||
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
|
||||
display SheetExercise = "Aufgabenstellung"
|
||||
@ -557,7 +564,7 @@ derivePersistField "Theme"
|
||||
|
||||
|
||||
newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
|
||||
deriving (Show, Read, Eq)
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
|
||||
instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
|
||||
fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
|
||||
@ -832,8 +839,7 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
|
||||
instance Hashable a => Hashable (PredLiteral a)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, sumEncoding = ObjectWithSingleField
|
||||
, unwrapUnaryRecords = True
|
||||
, sumEncoding = TaggedObject "val" "var"
|
||||
} ''PredLiteral
|
||||
|
||||
instance PathPiece a => PathPiece (PredLiteral a) where
|
||||
|
||||
46
src/Network/Mime/TH.hs
Normal file
46
src/Network/Mime/TH.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module Network.Mime.TH
|
||||
( mimeMapFile
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (lift)
|
||||
import Language.Haskell.TH hiding (Extension)
|
||||
import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Network.Mime
|
||||
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
|
||||
mimeMapFile :: FilePath -> ExpQ
|
||||
mimeMapFile file = do
|
||||
qAddDependentFile file
|
||||
|
||||
mappings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
|
||||
let
|
||||
coMappings :: [(Extension, MimeType)]
|
||||
coMappings = do
|
||||
(mimeType : extensions) <- filter (not . Text.null) . Text.words <$> mappings
|
||||
ext <- extensions
|
||||
return (ext, Text.encodeUtf8 mimeType)
|
||||
|
||||
mimeMap = Map.fromListWithKey duplicateError coMappings
|
||||
|
||||
duplicateError ext t1 t2 = error . Text.unpack $ "Duplicate mimeMap-entries for extension " <> ext <> ": " <> Text.decodeUtf8 t1 <> ", " <> Text.decodeUtf8 t2
|
||||
|
||||
|
||||
lift mimeMap
|
||||
|
||||
isComment :: Text -> Bool
|
||||
isComment line = or
|
||||
[ commentSymbol `Text.isPrefixOf` Text.stripStart line
|
||||
, Text.null $ Text.strip line
|
||||
]
|
||||
where
|
||||
commentSymbol = "#"
|
||||
@ -68,6 +68,11 @@ import qualified System.FilePath as FilePath
|
||||
|
||||
import Jose.Jwt (JwtEncoding(..))
|
||||
|
||||
import System.FilePath.Glob
|
||||
import Handler.Utils.Submission.TH
|
||||
import Network.Mime
|
||||
import Network.Mime.TH
|
||||
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
@ -77,6 +82,7 @@ data AppSettings = AppSettings
|
||||
-- ^ Directory from which to serve static files.
|
||||
, appDatabaseConf :: PostgresConf
|
||||
-- ^ Configuration settings for accessing the database.
|
||||
, appAutoDbMigrate :: Bool
|
||||
, appLdapConf :: Maybe LdapConf
|
||||
-- ^ Configuration settings for accessing the LDAP-directory
|
||||
, appSmtpConf :: Maybe SmtpConf
|
||||
@ -345,6 +351,7 @@ instance FromJSON AppSettings where
|
||||
#endif
|
||||
appStaticDir <- o .: "static-dir"
|
||||
appDatabaseConf <- o .: "database"
|
||||
appAutoDbMigrate <- o .: "auto-db-migrate"
|
||||
let nonEmptyHost LdapConf{..} = case ldapHost of
|
||||
Ldap.Tls host _ -> not $ null host
|
||||
Ldap.Plain host -> not $ null host
|
||||
@ -420,6 +427,13 @@ makeClassy_ ''AppSettings
|
||||
widgetFileSettings :: WidgetFileSettings
|
||||
widgetFileSettings = def
|
||||
|
||||
|
||||
submissionBlacklist :: [Pattern]
|
||||
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
||||
|
||||
mimeLookup :: FileName -> MimeType
|
||||
mimeLookup = mimeByExt $(mimeMapFile "config/mimetypes") defaultMimeType
|
||||
|
||||
-- The rest of this file contains settings which rarely need changing by a
|
||||
-- user.
|
||||
|
||||
|
||||
76
src/Utils.hs
76
src/Utils.hs
@ -77,6 +77,8 @@ import Network.Wai (requestMethod)
|
||||
|
||||
import Data.Time.Clock
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
|
||||
{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
|
||||
|
||||
|
||||
@ -121,6 +123,29 @@ type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBase
|
||||
-- Icons --
|
||||
-----------
|
||||
|
||||
-- We collect all used icons here for an overview.
|
||||
-- For consistency, some conditional icons are also provided, e.g. `isIvisble`
|
||||
|
||||
iconQuestion :: Markup
|
||||
iconQuestion = [shamlet|<i .fas .fa-question-circle>|]
|
||||
|
||||
iconHint :: Markup
|
||||
iconHint = [shamlet|<i .fas .fa-life-ring>|]
|
||||
|
||||
iconSolution :: Markup
|
||||
iconSolution = [shamlet|<i .fas .fa-exclamation-circle>|]
|
||||
|
||||
iconMarking :: Markup
|
||||
iconMarking = [shamlet|<i .fas .fa-check-circle>|]
|
||||
|
||||
fileDownload :: Markup
|
||||
fileDownload = [shamlet|<i .fas .fa-file-download>|]
|
||||
|
||||
zipDownload :: Markup
|
||||
zipDownload = [shamlet|<i .fas .fa-file-archive>|]
|
||||
|
||||
-- Conditional icons
|
||||
|
||||
isVisible :: Bool -> Markup
|
||||
-- ^ Display an icon that denotes that something™ is visible or invisible
|
||||
isVisible True = [shamlet|<i .fas .fa-eye>|]
|
||||
@ -162,6 +187,7 @@ boolSymbol True = [shamlet|<i .fas .fa-check>|]
|
||||
boolSymbol False = [shamlet|<i .fas .fa-times>|]
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
---------------------
|
||||
@ -260,6 +286,22 @@ textPercent x = lz <> pack (show rx) <> "%"
|
||||
textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
|
||||
textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole
|
||||
|
||||
-- | Convert number of bytes to human readable format
|
||||
textBytes :: Integral a => a -> Text
|
||||
textBytes x
|
||||
| v < kb = rshow v <> "B"
|
||||
| v < mb = rshow (v/kb) <> "KB"
|
||||
| v < gb = rshow (v/mb) <> "MB"
|
||||
| otherwise = rshow (v/gb) <> "GB"
|
||||
where
|
||||
v = fromIntegral x
|
||||
kb = 1024
|
||||
mb = 1024 * kb
|
||||
gb = 1024 * mb
|
||||
rshow :: Double -> Text
|
||||
rshow = tshow . floorToDigits 1
|
||||
|
||||
|
||||
stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
|
||||
stepTextCounterCI = CI.map stepTextCounter
|
||||
|
||||
@ -292,6 +334,13 @@ notUsedT = notUsed
|
||||
roundToNearestMultiple :: Int -> Int -> Int
|
||||
roundToNearestMultiple m n = (n `div` m + 1) * m
|
||||
|
||||
roundToDigits :: (RealFrac a, Integral b) => b -> a -> a
|
||||
roundToDigits d x = fromInteger (round $ x * prec) / prec
|
||||
where prec = 10^d
|
||||
|
||||
floorToDigits :: (RealFrac a, Integral b) => b -> a -> a
|
||||
floorToDigits d x = fromInteger (floor $ x * prec) / prec
|
||||
where prec = 10^d
|
||||
|
||||
|
||||
|
||||
@ -335,7 +384,26 @@ lastMaybe (_:t) = lastMaybe t
|
||||
lastMaybe' :: [a] -> Maybe a
|
||||
lastMaybe' l = fmap snd $ l ^? _Snoc
|
||||
|
||||
-- | Merge two lists of attribures, also see `Utils.Form.insertAttrs`
|
||||
|
||||
-- | Merge/Add any attribute-value pair to an existing list of such pairs.
|
||||
-- If the attribute exists, the new valu will be prepended, separated by a single empty space
|
||||
-- Also see `Utils.mergeAttrs`
|
||||
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
|
||||
insertAttr attr valu = aux
|
||||
where
|
||||
aux :: [(Text,Text)] -> [(Text,Text)]
|
||||
aux [] = [(attr,valu)]
|
||||
aux (p@(a,v) : t)
|
||||
| attr==a = (a, Text.append valu $ Text.cons ' ' v) : t
|
||||
| otherwise = p : aux t
|
||||
|
||||
-- | Add another class attribute; special function for a frequent case to avoid mistyping "class".
|
||||
-- Also see `Utils.insertAttrs`
|
||||
insertClass :: Text -> [(Text,Text)] -> [(Text,Text)]
|
||||
insertClass = insertAttr "class"
|
||||
|
||||
-- | Append two lists of attributes, merging the class attribute only.
|
||||
-- Also see `Utils.insertAttr` to merge any attribute
|
||||
mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
|
||||
mergeAttrs = mergeAttrs' `on` sort
|
||||
where
|
||||
@ -363,6 +431,9 @@ partitionWith f (x:xs) = case f x of
|
||||
Right c -> (bs, c:cs)
|
||||
where (bs,cs) = partitionWith f xs
|
||||
|
||||
nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
|
||||
nonEmpty' = maybe empty pure . nonEmpty
|
||||
|
||||
----------
|
||||
-- Sets --
|
||||
----------
|
||||
@ -372,7 +443,8 @@ setIntersections :: Ord a => [Set a] -> Set a
|
||||
setIntersections [] = Set.empty
|
||||
setIntersections (h:t) = foldl' Set.intersection h t
|
||||
|
||||
|
||||
setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
|
||||
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
|
||||
@ -8,7 +8,7 @@ import Settings
|
||||
|
||||
import Utils.Parameters
|
||||
|
||||
-- import Text.Blaze (toMarkup) -- for debugging
|
||||
import Text.Blaze (Markup)
|
||||
import qualified Text.Blaze.Internal as Blaze (null)
|
||||
import qualified Data.Text as T
|
||||
|
||||
@ -33,9 +33,10 @@ import Web.PathPieces
|
||||
|
||||
import Data.UUID
|
||||
|
||||
import Utils.Message
|
||||
import Utils.PathPiece
|
||||
import Utils.Route
|
||||
import Utils
|
||||
-- import Utils.Message
|
||||
-- import Utils.PathPiece
|
||||
-- import Utils.Route
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
@ -82,17 +83,8 @@ fslpI lbl placeholder
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
-- | Merge/Add an attribute-value Pair to an existing list of such pairs.
|
||||
-- If the attribute exists, the new valu will be prepended, separated by a single empty space
|
||||
-- Also see `Utils.mergeAttrs`
|
||||
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
|
||||
insertAttr attr valu = aux
|
||||
where
|
||||
aux :: [(Text,Text)] -> [(Text,Text)]
|
||||
aux [] = [(attr,valu)]
|
||||
aux (p@(a,v) : t)
|
||||
| attr==a = (a, T.append valu $ cons ' ' v) : t
|
||||
| otherwise = p : aux t
|
||||
|
||||
-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes
|
||||
|
||||
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
|
||||
@ -161,7 +153,7 @@ inputReadonly :: FieldSettings site -> FieldSettings site
|
||||
inputReadonly = addAttr "readonly" ""
|
||||
|
||||
addAutosubmit :: FieldSettings site -> FieldSettings site
|
||||
addAutosubmit = addAttr "data-autosubmit" ""
|
||||
addAutosubmit = addAttr "uw-auto-submit-input" ""
|
||||
|
||||
------------------------------------------------
|
||||
-- Unique Form Identifiers to avoid accidents --
|
||||
@ -191,6 +183,8 @@ data FormIdentifier
|
||||
| FIDCourseRegister
|
||||
| FIDuserRights
|
||||
| FIDcUserNote
|
||||
| FIDcRegField
|
||||
| FIDcRegButton
|
||||
| FIDAdminDemo
|
||||
| FIDUserDelete
|
||||
| FIDCommunication
|
||||
@ -348,9 +342,6 @@ combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a
|
||||
submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
|
||||
submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""
|
||||
|
||||
autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
|
||||
autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit
|
||||
|
||||
-- | just Html for a Submit-Button
|
||||
submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
|
||||
submitButtonView = buttonView BtnSubmit
|
||||
@ -507,6 +498,10 @@ renderAForm formLayout aform fragment = do
|
||||
let widget = $(widgetFile "widgets/aform/aform")
|
||||
return (res, widget)
|
||||
|
||||
renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here)
|
||||
(Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
renderWForm formLayout = renderAForm formLayout . wFormToAForm
|
||||
|
||||
|
||||
-- | special id to identify form section headers, see 'aformSection' and 'formSection'
|
||||
-- currently only treated by form generation through 'renderAForm'
|
||||
@ -638,6 +633,10 @@ aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
|
||||
((a, vs), ints, enctype) <- lift f
|
||||
writer ((a, ints, enctype), vs)
|
||||
|
||||
infixl 4 `fmapAForm`
|
||||
|
||||
fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
|
||||
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints
|
||||
|
||||
---------------------------------------------
|
||||
-- Special variants of @mopt@, @mreq@, ... --
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module Utils.Frontend.Modal
|
||||
( Modal(..)
|
||||
, customModal
|
||||
, modal
|
||||
, modal, msgModal
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -11,6 +11,9 @@ import Utils.Route
|
||||
|
||||
import Settings (widgetFile)
|
||||
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
|
||||
data Modal site = Modal
|
||||
{ modalTriggerId
|
||||
@ -37,3 +40,15 @@ modal modalTrigger' modalContent = customModal Modal{..}
|
||||
modalTriggerId = Nothing
|
||||
modalId = Nothing
|
||||
modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
|
||||
|
||||
|
||||
-- | Variant of `modal` for use in messages (uses a different id generator to avoid collisions)
|
||||
msgModal :: WidgetT site IO ()
|
||||
-> Either (SomeRoute site) (WidgetT site IO ())
|
||||
-> WidgetT site IO ()
|
||||
msgModal modalTrigger' modalContent = do
|
||||
modalTriggerId <- Just . UUID.toText <$> liftIO getRandom
|
||||
modalId <- Just . UUID.toText <$> liftIO getRandom
|
||||
customModal Modal{..}
|
||||
where
|
||||
modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
|
||||
|
||||
@ -27,6 +27,9 @@ _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l
|
||||
_InnerJoinRight :: Lens' (E.InnerJoin l r) r
|
||||
_InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
|
||||
|
||||
_nullable :: MonoFoldable mono => Prism' mono (NonNull mono)
|
||||
_nullable = prism' toNullable fromNullable
|
||||
|
||||
|
||||
-----------------------------------
|
||||
-- Lens Definitions for our Types
|
||||
@ -80,6 +83,8 @@ makeLenses_ ''SheetGrading
|
||||
|
||||
makeLenses_ ''SheetType
|
||||
|
||||
makePrisms ''SheetGroup
|
||||
|
||||
makePrisms ''AuthResult
|
||||
|
||||
makePrisms ''FormResult
|
||||
@ -112,6 +117,8 @@ makePrisms ''OccurenceException
|
||||
|
||||
makeLenses_ ''Occurences
|
||||
|
||||
makeLenses_ ''PredDNF
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
@ -3,6 +3,7 @@ module Utils.Sheet where
|
||||
import Import.NoFoundation
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Database.Esqueleto.Internal.Language (From) -- How to avoid this import?
|
||||
|
||||
-- DB Queries for Sheets that are used in several places
|
||||
|
||||
@ -44,3 +45,49 @@ sheetOldUnassigned tid ssh csh = do
|
||||
[] -> Nothing
|
||||
[E.Value shn] -> Just shn
|
||||
_ -> error "SQL Query with limit 1 returned more than one result"
|
||||
|
||||
-- | Return a specfic file from a `Sheet`
|
||||
sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File]
|
||||
sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
|
||||
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
)
|
||||
-- return file entity
|
||||
return file
|
||||
|
||||
-- | Return all files of a certain `SheetFileType` for a `Sheet`
|
||||
sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File]
|
||||
sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
|
||||
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((sFile E.^. SheetFileType E.==. E.val sft )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
)
|
||||
-- return file entity
|
||||
return file
|
||||
|
||||
-- | Check whether a sheet has any files for a given file type
|
||||
hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SheetFile))
|
||||
-- hasSheetFileQuery :: (E.Esqueleto query expr backend)
|
||||
=> expr (Entity Sheet) -> SheetFileType -> expr (E.Value Bool)
|
||||
hasSheetFileQuery sheet sft =
|
||||
E.exists $ E.from $ \sFile ->
|
||||
E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))
|
||||
@ -49,6 +49,6 @@ extra-deps:
|
||||
- quickcheck-classes-0.4.14
|
||||
- semirings-0.2.1.1
|
||||
|
||||
- systemd-1.1.2
|
||||
- systemd-1.2.0
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
@ -34,6 +34,10 @@
|
||||
}
|
||||
}
|
||||
|
||||
.alerts--elevated {
|
||||
z-index: 1000;
|
||||
}
|
||||
|
||||
.alerts__toggler--visible {
|
||||
top: -40px;
|
||||
opacity: 1;
|
||||
|
||||
@ -1,8 +1,16 @@
|
||||
(function collonadeClosure() {
|
||||
(function () {
|
||||
'use strict';
|
||||
|
||||
window.HttpClient = (function() {
|
||||
|
||||
var _responseInterceptors = [];
|
||||
|
||||
function addResponseInterceptor(interceptor) {
|
||||
if (typeof interceptor === 'function') {
|
||||
_responseInterceptors.push(interceptor);
|
||||
}
|
||||
}
|
||||
|
||||
function _fetch(url, method, additionalHeaders, body) {
|
||||
var requestOptions = {
|
||||
credentials: 'same-origin',
|
||||
@ -15,7 +23,17 @@
|
||||
requestOptions.headers[headerKey] = additionalHeaders[headerKey];
|
||||
});
|
||||
|
||||
return fetch(url, requestOptions);
|
||||
return fetch(url, requestOptions).then(
|
||||
function(response) {
|
||||
_responseInterceptors.forEach(function(interceptor) { interceptor(response); });
|
||||
return Promise.resolve(response);
|
||||
},
|
||||
function(error) {
|
||||
return Promise.reject(error);
|
||||
}
|
||||
).catch(function(error) {
|
||||
console.error(error);
|
||||
});
|
||||
}
|
||||
|
||||
return {
|
||||
@ -25,6 +43,7 @@
|
||||
post: function(url, headers, body) {
|
||||
return _fetch(url, 'POST', headers, body);
|
||||
},
|
||||
addResponseInterceptor: addResponseInterceptor,
|
||||
}
|
||||
})();
|
||||
})();
|
||||
|
||||
@ -30,7 +30,7 @@
|
||||
* Example usage:
|
||||
* <div .alerts uw-alerts>
|
||||
* <div .alerts__toggler>
|
||||
* <div .alert.alert-info>
|
||||
* <div .alert.alert-info>
|
||||
* <div .alert__closer>
|
||||
* <div .alert__icon>
|
||||
* <div .alert__content>
|
||||
@ -42,6 +42,7 @@
|
||||
var ALERTS_UTIL_SELECTOR = '[uw-alerts]';
|
||||
|
||||
var ALERTS_INITIALIZED_CLASS = 'alerts--initialized';
|
||||
var ALERTS_ELEVATED_CLASS = 'alerts--elevated';
|
||||
var ALERTS_TOGGLER_CLASS = 'alerts__toggler';
|
||||
var ALERTS_TOGGLER_VISIBLE_CLASS = 'alerts__toggler--visible';
|
||||
var ALERTS_TOGGLER_APPEAR_DELAY = 120;
|
||||
@ -49,6 +50,8 @@
|
||||
var ALERT_CLASS = 'alert';
|
||||
var ALERT_INITIALIZED_CLASS = 'alert--initialized';
|
||||
var ALERT_CLOSER_CLASS = 'alert__closer';
|
||||
var ALERT_ICON_CLASS = 'alert__icon';
|
||||
var ALERT_CONTENT_CLASS = 'alert__content';
|
||||
var ALERT_INVISIBLE_CLASS = 'alert--invisible';
|
||||
var ALERT_AUTO_HIDE_DELAY = 10;
|
||||
var ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success';
|
||||
@ -73,6 +76,9 @@
|
||||
initToggler();
|
||||
initAlerts();
|
||||
|
||||
// register http client interceptor to filter out Alerts Header
|
||||
setupHttpInterceptor();
|
||||
|
||||
// mark initialized
|
||||
element.classList.add(ALERTS_INITIALIZED_CLASS);
|
||||
|
||||
@ -96,7 +102,6 @@
|
||||
});
|
||||
togglerElement.classList.remove(ALERTS_TOGGLER_VISIBLE_CLASS);
|
||||
});
|
||||
element.classList.add(ALERTS_INITIALIZED_CLASS);
|
||||
}
|
||||
|
||||
function initAlerts() {
|
||||
@ -119,8 +124,6 @@
|
||||
toggleAlert(alertElement);
|
||||
}, autoHideDelay * 1000);
|
||||
}
|
||||
|
||||
alertElement.classList.add(ALERTS_INITIALIZED_CLASS);
|
||||
}
|
||||
|
||||
function toggleAlert(alertEl, visible) {
|
||||
@ -143,6 +146,58 @@
|
||||
}, ALERTS_TOGGLER_APPEAR_DELAY);
|
||||
}
|
||||
|
||||
function setupHttpInterceptor() {
|
||||
if (HttpClient) {
|
||||
HttpClient.addResponseInterceptor(responseInterceptor.bind(this));
|
||||
}
|
||||
}
|
||||
|
||||
function elevateAlerts() {
|
||||
element.classList.add(ALERTS_ELEVATED_CLASS);
|
||||
}
|
||||
|
||||
function responseInterceptor(response) {
|
||||
var alerts;
|
||||
for (var header of response.headers) {
|
||||
if (header[0] === 'alerts') {
|
||||
alerts = JSON.parse(header[1]);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (alerts) {
|
||||
alerts.forEach(function(alert) {
|
||||
var alertElement = createAlertElement(alert.status, alert.content);
|
||||
element.appendChild(alertElement);
|
||||
alertElements.push(alertElement);
|
||||
initAlert(alertElement);
|
||||
});
|
||||
|
||||
elevateAlerts();
|
||||
}
|
||||
}
|
||||
|
||||
function createAlertElement(type, content) {
|
||||
var alertElement = document.createElement('div');
|
||||
alertElement.classList.add(ALERT_CLASS, 'alert-' + type);
|
||||
|
||||
var alertCloser = document.createElement('div');
|
||||
alertCloser.classList.add(ALERT_CLOSER_CLASS);
|
||||
|
||||
var alertIcon = document.createElement('div');
|
||||
alertIcon.classList.add(ALERT_ICON_CLASS);
|
||||
|
||||
var alertContent = document.createElement('div');
|
||||
alertContent.classList.add(ALERT_CONTENT_CLASS);
|
||||
alertContent.innerHTML = content;
|
||||
|
||||
alertElement.appendChild(alertCloser);
|
||||
alertElement.appendChild(alertIcon);
|
||||
alertElement.appendChild(alertContent);
|
||||
|
||||
return alertElement;
|
||||
}
|
||||
|
||||
return init();
|
||||
};
|
||||
|
||||
|
||||
@ -286,6 +286,64 @@
|
||||
setup: autoSubmitButtonUtil,
|
||||
});
|
||||
|
||||
/**
|
||||
*
|
||||
* Auto Submit Input Utility
|
||||
* Programmatically submits forms when a certain input changes value
|
||||
*
|
||||
* Attribute: uw-auto-submit-input
|
||||
*
|
||||
* Example usage:
|
||||
* <input type="text" uw-auto-submit-input />
|
||||
*/
|
||||
|
||||
var AUTO_SUBMIT_INPUT_UTIL_NAME = 'autoSubmitInput';
|
||||
var AUTO_SUBMIT_INPUT_UTIL_SELECTOR = '[uw-auto-submit-input]';
|
||||
|
||||
var AUTO_SUBMIT_INPUT_INITIALIZED_CLASS = 'auto-submit-input--initialized';
|
||||
|
||||
var autoSubmitInputUtil = function(element) {
|
||||
var form;
|
||||
var debouncedHandler;
|
||||
|
||||
function autoSubmit() {
|
||||
form.submit();
|
||||
}
|
||||
|
||||
function init() {
|
||||
if (!element) {
|
||||
throw new Error('Auto Submit Input utility needs to be passed an element!');
|
||||
}
|
||||
|
||||
form = element.form;
|
||||
if (!form) {
|
||||
throw new Error('Could not determine associated form for auto submit input');
|
||||
}
|
||||
|
||||
debouncedHandler = debounce(autoSubmit, 500);
|
||||
|
||||
element.addEventListener('input', debouncedHandler);
|
||||
|
||||
element.classList.add(AUTO_SUBMIT_INPUT_INITIALIZED_CLASS);
|
||||
|
||||
return {
|
||||
name: AUTO_SUBMIT_INPUT_UTIL_NAME,
|
||||
element: element,
|
||||
destroy: function() {
|
||||
element.removeEventListener('input', debouncedHandler);
|
||||
},
|
||||
};
|
||||
}
|
||||
|
||||
return init();
|
||||
};
|
||||
|
||||
formUtilities.push({
|
||||
name: AUTO_SUBMIT_INPUT_UTIL_NAME,
|
||||
selector: AUTO_SUBMIT_INPUT_UTIL_SELECTOR,
|
||||
setup: autoSubmitInputUtil,
|
||||
});
|
||||
|
||||
/**
|
||||
*
|
||||
* Form Error Remover Utility
|
||||
@ -416,7 +474,7 @@
|
||||
};
|
||||
}
|
||||
|
||||
return init();
|
||||
return init();
|
||||
};
|
||||
|
||||
formUtilities.push({
|
||||
@ -425,6 +483,22 @@
|
||||
setup: datepickerUtil,
|
||||
});
|
||||
|
||||
// debounce function, taken from Underscore.js
|
||||
function debounce(func, wait, immediate) {
|
||||
var timeout;
|
||||
return function() {
|
||||
var context = this, args = arguments;
|
||||
var later = function() {
|
||||
timeout = null;
|
||||
if (!immediate) func.apply(context, args);
|
||||
};
|
||||
var callNow = immediate && !timeout;
|
||||
clearTimeout(timeout);
|
||||
timeout = setTimeout(later, wait);
|
||||
if (callNow) func.apply(context, args);
|
||||
};
|
||||
}
|
||||
|
||||
// register the collected form utilities
|
||||
if (UtilRegistry) {
|
||||
formUtilities.forEach(UtilRegistry.register);
|
||||
|
||||
@ -116,12 +116,14 @@
|
||||
var requestBody = serializeForm(submitButton, enctype);
|
||||
|
||||
if (requestFn && requestBody) {
|
||||
var headers = {'Mass-Input-Shortcircuit': massInputId};
|
||||
|
||||
if (enctype !== 'multipart/form-data')
|
||||
headers['Content-Type'] = enctype;
|
||||
|
||||
requestFn(
|
||||
url,
|
||||
{
|
||||
'Content-Type': enctype,
|
||||
'Mass-Input-Shortcircuit': massInputId,
|
||||
},
|
||||
headers,
|
||||
requestBody,
|
||||
).then(function(response) {
|
||||
return response.text();
|
||||
|
||||
@ -9,17 +9,16 @@
|
||||
#{matnr}
|
||||
$nothing
|
||||
_{MsgNoMatrikelKnown}
|
||||
<dt .deflist__dt>_{MsgRegisteredHeader}
|
||||
$maybe date <- mRegAt
|
||||
<dt .deflist__dt>_{MsgRegisteredSince}
|
||||
<dd .deflist__dd>#{date}
|
||||
<dt .deflist__dt>
|
||||
<dd .deflist__dd>
|
||||
<div .course__registration>
|
||||
<a id="register-form">
|
||||
<form method=post action=@{currentRoute}#register-form enctype=#{registerEnctype}>
|
||||
^{registerView}
|
||||
$maybe date <- mRegAt
|
||||
_{MsgRegisteredSince date}
|
||||
|
||||
|
||||
<dt .deflist__dt> _{MsgStudyTerms}
|
||||
^{regButtonWidget}
|
||||
$maybe _ <- mRegistration
|
||||
<p>
|
||||
_{MsgCourseDeregisterLecturerTip}
|
||||
<dt .deflist__dt>_{MsgStudyTerms}
|
||||
<dd .deflist__dd>
|
||||
$if null studies
|
||||
_{MsgNoStudyTermsKnown}
|
||||
@ -35,15 +34,16 @@
|
||||
<th .table__th>_{MsgStudyFeatureUpdate}
|
||||
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
|
||||
$with _ <- notUsedT studyFeaturesUser
|
||||
<tr.table__row>
|
||||
<tr .table__row>
|
||||
<td .table__td>_{field}#{notUsedT studyFeaturesField}
|
||||
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
|
||||
<td .table__td>_{studyFeaturesType}
|
||||
<td .table__td>#{display studyFeaturesSemester}
|
||||
<td .table__td>#{hasTickmark studyFeaturesValid}
|
||||
<td .table__td>^{formatTimeW SelFormatDate studyFeaturesUpdated}
|
||||
$maybe _ <- mRegistration
|
||||
<dt .deflist__dt>_{MsgCourseStudyFeature}
|
||||
<dd .deflist__dd>^{regFieldWidget}
|
||||
|
||||
<section>
|
||||
<a id="note-form">
|
||||
<form method=post action=@{currentRoute}#note-form enctype=#{noteEnctype}>
|
||||
^{noteView}
|
||||
^{noteWidget}
|
||||
|
||||
@ -33,6 +33,16 @@ $newline never
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall assi <- assistants
|
||||
<li>^{nameEmailWidget' assi}
|
||||
|
||||
$with numtutor <- length tutors
|
||||
$if numtutor /= 0
|
||||
<dt .deflist__dt>_{MsgTutorsFor numtutor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall tutor <- tutors
|
||||
<li>^{nameEmailWidget' tutor}
|
||||
|
||||
$with numcorrector <- length correctors
|
||||
$if numcorrector /= 0
|
||||
<dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
|
||||
@ -73,7 +83,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
$# regForm is defined through templates/widgets/registerForm
|
||||
^{regForm}
|
||||
$maybe date <- mRegAt
|
||||
_{MsgRegisteredSince date}
|
||||
_{MsgRegisteredSince} #{date}
|
||||
<dt .deflist__dt>
|
||||
Material
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -20,3 +20,7 @@
|
||||
Temporäre Dateien einer eventuellen Vorkorrektur müssen also durch das Hochladen der
|
||||
Korrekturen des letzten Korrektors gelöscht werden, falls diese den Abgabenden
|
||||
nicht zur Verfügung gestellt werden sollen.
|
||||
|
||||
$maybe maxUpload <- maxUploadMB
|
||||
<p>
|
||||
Das Limit für die Dateigröße beträgt momentan #{textBytes maxUpload}
|
||||
8
templates/i18n/html-input/de.hamlet
Normal file
8
templates/i18n/html-input/de.hamlet
Normal file
@ -0,0 +1,8 @@
|
||||
<h3>Hinweis: Leerzeilen werden entfernt!
|
||||
<p>
|
||||
Das Eingabefeld für Mitteilungstext/Beschreibung akzeptiert derzeit nur Html.
|
||||
Zeilumbrüche spielen dementsprechend keine Rolle, können aber mit
|
||||
<code><br>
|
||||
eingefügt werden.
|
||||
<p>
|
||||
Für die Zukunft ist Markdown Unterstützung inklusive Editor geplant.
|
||||
@ -16,7 +16,7 @@ $maybe descr <- materialDescription
|
||||
<dt .deflist__dt>_{MsgFileModified}
|
||||
<dd .deflist__dd>#{materialLastEdit}
|
||||
|
||||
$if hasFiles || True
|
||||
$if hasFiles
|
||||
<section>
|
||||
<h2>_{MsgMaterialFiles}
|
||||
<h2>^{simpleLinkI (SomeMessage MsgMaterialFiles) zipLink}
|
||||
^{fileTable}
|
||||
|
||||
@ -0,0 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}
|
||||
<ul>
|
||||
$forall email <- alreadyRegistered
|
||||
<li style="font-family: monospace">#{email}
|
||||
@ -0,0 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}
|
||||
<ul>
|
||||
$forall email <- registeredNoField
|
||||
<li style="font-family: monospace">#{email}
|
||||
@ -1 +1,3 @@
|
||||
<p>
|
||||
_{MsgPressSaveToSave}
|
||||
^{corrForm}
|
||||
|
||||
@ -22,7 +22,9 @@ $maybe cID <- mcid
|
||||
$nothing
|
||||
<li>#{display time}
|
||||
|
||||
|
||||
$if maySubmit
|
||||
<section>
|
||||
^{formWidget}
|
||||
$if maySubmit
|
||||
<section>
|
||||
<h2>_{MsgSubmissionReplace}
|
||||
^{formWidget}
|
||||
$nothing
|
||||
^{formWidget}
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
<section>
|
||||
$maybe summary' <- summary
|
||||
<h2>
|
||||
#{summary'}
|
||||
$# $maybe summary' <- summary
|
||||
$# <h2>
|
||||
$# #{summary'}
|
||||
<p>
|
||||
#{content}
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
$newline never
|
||||
<td *{mergeAttrs attrs [("class", "table__td")]}>
|
||||
<td *{insertClass "table__td" attrs}>
|
||||
<div .table__td-content>
|
||||
^{widget}
|
||||
|
||||
6
templates/widgets/massinput/submissionUsers/add.hamlet
Normal file
6
templates/widgets/massinput/submissionUsers/add.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
#{csrf}
|
||||
^{fvInput addView}
|
||||
<td>
|
||||
^{fvInput btn}
|
||||
@ -0,0 +1,10 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
<span style="font-family: monospace">
|
||||
#{email}
|
||||
<td>
|
||||
<div .tooltip>
|
||||
<div .tooltip__handle>
|
||||
<div .tooltip__content>
|
||||
_{MsgEmailInvitationWarning}
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
#{csrf}
|
||||
^{nameEmailWidget userEmail userDisplayName userSurname}
|
||||
13
templates/widgets/massinput/submissionUsers/layout.hamlet
Normal file
13
templates/widgets/massinput/submissionUsers/layout.hamlet
Normal file
@ -0,0 +1,13 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
$maybe delButton <- delButtons !? coord
|
||||
^{fvInput delButton}
|
||||
$maybe addWdgt <- addWdgts !? (0, 0)
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
^{addWdgt}
|
||||
@ -33,10 +33,10 @@ data DBAction = DBClear
|
||||
|
||||
argsDescr :: [OptDescr DBAction]
|
||||
argsDescr =
|
||||
[ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user"
|
||||
, Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)"
|
||||
, Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration"
|
||||
, Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data"
|
||||
[ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user"
|
||||
, Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)"
|
||||
, Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration"
|
||||
, Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data"
|
||||
]
|
||||
|
||||
|
||||
@ -571,3 +571,8 @@ fillDb = do
|
||||
void . insert' $ DegreeCourse dbs sdBsc sdMath
|
||||
void . insert' $ Lecturer gkleen dbs CourseLecturer
|
||||
void . insert' $ Lecturer jost dbs CourseAssistant
|
||||
|
||||
void . insert $ SystemMessage (Just now) Nothing False Success "de" "System-Nachrichten werden angezeigt" Nothing
|
||||
void . insert $ SystemMessage (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung")
|
||||
void . insert $ SystemMessage (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
|
||||
void . insert $ SystemMessage Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
|
||||
|
||||
58
test/FoundationSpec.hs
Normal file
58
test/FoundationSpec.hs
Normal file
@ -0,0 +1,58 @@
|
||||
module FoundationSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import ModelSpec ()
|
||||
|
||||
import qualified Data.CryptoID as CID
|
||||
import Yesod.EmbeddedStatic
|
||||
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
|
||||
instance Arbitrary (Route Auth) where
|
||||
arbitrary = oneof
|
||||
[ return CheckR
|
||||
, return LoginR
|
||||
, return LogoutR
|
||||
, PluginR <$> arbitrary <*> arbitrary
|
||||
]
|
||||
|
||||
instance Arbitrary (Route EmbeddedStatic) where
|
||||
arbitrary = embeddedResourceR <$> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary CourseR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SheetR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SubmissionR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary MaterialR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary TutorialR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (Route UniWorX) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary a => Arbitrary (CID.CryptoID ns a) where
|
||||
arbitrary = CID.CryptoID <$> arbitrary
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
parallel $
|
||||
lawsCheckHspec (Proxy @(Route UniWorX))
|
||||
[ eqLaws, hashableLaws, jsonLaws, jsonKeyLaws, pathPieceLaws ]
|
||||
@ -148,6 +148,10 @@ instance Arbitrary AuthenticationMode where
|
||||
instance Arbitrary LecturerType where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary a => Arbitrary (ZIPArchiveName a) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
|
||||
spec :: Spec
|
||||
@ -211,6 +215,8 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @LecturerType)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text)))
|
||||
[ eqLaws, ordLaws, showReadLaws, pathPieceLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
|
||||
17
test/Test/QuickCheck/Classes/Binary.hs
Normal file
17
test/Test/QuickCheck/Classes/Binary.hs
Normal file
@ -0,0 +1,17 @@
|
||||
module Test.QuickCheck.Classes.Binary
|
||||
( binaryLaws
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Classes
|
||||
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Binary
|
||||
import Data.Binary.Put
|
||||
|
||||
binaryLaws :: forall a. (Arbitrary a, Binary a, Eq a, Show a) => Proxy a -> Laws
|
||||
binaryLaws _ = Laws "Binary"
|
||||
[ ("Partial Isomorphism", property $ \(a :: a) -> decode (encode a) == Just a)
|
||||
, ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as))
|
||||
]
|
||||
@ -26,6 +26,7 @@ import Test.QuickCheck.Classes.Hashable as X
|
||||
import Test.QuickCheck.Classes.JSON as X
|
||||
import Test.QuickCheck.Classes.HttpApiData as X
|
||||
import Test.QuickCheck.Classes.Universe as X
|
||||
import Test.QuickCheck.Classes.Binary as X
|
||||
import Data.Proxy as X
|
||||
import Data.UUID as X (UUID)
|
||||
import System.IO as X (hPrint, hPutStrLn, stderr)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user