diff --git a/ChangeLog.md b/ChangeLog.md
index c50e244b7..9f07bd783 100644
--- a/ChangeLog.md
+++ b/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
diff --git a/config/mimetypes b/config/mimetypes
new file mode 100644
index 000000000..dd3fe4224
--- /dev/null
+++ b/config/mimetypes
@@ -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
diff --git a/config/settings.yml b/config/settings.yml
index 974b2e7e2..049692e5b 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -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:"
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 7030d0c15..c20d2af83 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -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
\ No newline at end of file
diff --git a/models/courses b/models/courses
index 4fcf67d65..5be19103a 100644
--- a/models/courses
+++ b/models/courses
@@ -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
diff --git a/models/tutorials b/models/tutorials
index 78571389c..444d988cd 100644
--- a/models/tutorials
+++ b/models/tutorials
@@ -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
diff --git a/models/users b/models/users
index cd08164d1..f0b3e683e 100644
--- a/models/users
+++ b/models/users
@@ -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
diff --git a/package.yaml b/package.yaml
index 4edc4d864..5dd414b33 100644
--- a/package.yaml
+++ b/package.yaml
@@ -197,7 +197,7 @@ when:
library:
source-dirs: src
when:
- - condition: (flag(dev)) || (flag(library-only))
+ - condition: flag(dev)
then:
ghc-options:
- -O0
diff --git a/routes b/routes
index 747207cc0..34a0bb4ff 100644
--- a/routes
+++ b/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
diff --git a/src/Application.hs b/src/Application.hs
index cc8843303..b39657de7 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -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"
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 9161ef86a..65f897acb 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -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
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 4e3845895..7a7cc36f8 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -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)
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 59a14a556..c294b0b07 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -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
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 34afeefeb..e75e27698 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -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
- $forall tutor <- tutors
+ $forall tutor <- tutTutors
-
^{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
@@ -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
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index b641b8ec3..7ae50af56 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -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
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 6187c4580..0a3b8c3fe 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -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}.|]
+
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 99149b23c..bdad11b37 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -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
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index 8228136d4..48a0a9337 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -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
diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs
index 255f26aea..6566a9cef 100644
--- a/src/Handler/Tutorial.hs
+++ b/src/Handler/Tutorial.hs
@@ -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
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 8e2a595e2..ed2334d5c 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -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|^{lbl}|]
+simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
+simpleLinkI lbl url = [whamlet|_{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)|]
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index c82c574ee..843160372 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@@ -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")
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 225886a1a..92fbccf72 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -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
@@ -735,7 +752,7 @@ multiUserField onlySuggested suggestions = Field{..}
$forall email <- suggestedEmails