diff --git a/.gitignore b/.gitignore index c37cbe326..f744360b3 100644 --- a/.gitignore +++ b/.gitignore @@ -29,6 +29,7 @@ uniworx.nix src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig +/instance .stack-work-* .directory tags diff --git a/.vscode/tasks.json b/.vscode/tasks.json new file mode 100644 index 000000000..c5f9eaf8e --- /dev/null +++ b/.vscode/tasks.json @@ -0,0 +1,16 @@ +{ + // See https://go.microsoft.com/fwlink/?LinkId=733558 + // for the documentation about the tasks.json format + "version": "2.0.0", + "tasks": [ + { + "label": "echo", + "type": "shell", + "command": "echo Hello", + "group": { + "kind": "build", + "isDefault": true + } + } + ] +} \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md index 401601e10..e5e39dee3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ + * Version 19.10.2018 + + Benutzer können sich in der Testphase komplett selbst löschen + + Hilfe Widget + + Benachrichtigungen per eMail für einige Ereignisse + * Version 18.09.2018 Tooltips funktionieren auch ohne JavaScript diff --git a/README.md b/README.md index be734df7b..e6b42fe4f 100644 --- a/README.md +++ b/README.md @@ -83,6 +83,10 @@ The following Description applies to Ubuntu or similar. ldap: https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/ +Instead of run.sh, use: +stack build --flag uniworx:dev --flag uniworx:library-only + + *** # PostgreSQL diff --git a/app/DevelMain.hs b/app/DevelMain.hs index b327943d8..0a7a89562 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -33,13 +33,15 @@ module DevelMain where import Prelude import Application (getApplicationRepl, shutdownApp) -import Control.Exception (finally) +import Control.Monad.Catch (finally) import Control.Monad ((>=>)) import Control.Concurrent import Data.IORef import Foreign.Store import Network.Wai.Handler.Warp import GHC.Word +import Control.Monad.Trans.Resource +import Control.Monad.IO.Class -- | Start or restart the server. -- newStore is from foreign-store. @@ -71,13 +73,14 @@ update = do -- | Start the server in a separate thread. start :: MVar () -- ^ Written to when the thread is killed. -> IO ThreadId - start done = do - (port, site, app) <- getApplicationRepl - forkIO (finally (runSettings (setPort port defaultSettings) app) - -- Note that this implies concurrency - -- between shutdownApp and the next app that is starting. - -- Normally this should be fine - (putMVar done () >> shutdownApp site)) + start done = runResourceT $ do + (port, site, app) <- getApplicationRepl + resourceForkIO $ do + finally (liftIO $ runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (liftIO $ putMVar done () >> shutdownApp site) -- | kill the server shutdown :: IO () diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index 102573866..d719af918 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -31,9 +31,21 @@ stanzas: - DUMMY_LOGIN - DETAILED_LOGGING - LOG_ALL + - LOGLEVEL + - ALLOW_DEPRECATED - PWFILE - CRYPTOID_KEYFILE - IP_FROM_HEADER + - MAILFROM_NAME + - MAILFROM_EMAIL + - MAILOBJECT_DOMAIN + - SMTPHOST + - SMTPPORT + - SMTPSSL + - SMTPUSER + - SMTPPASS + - SMTPTIMEOUT + - SMTPLIMIT # Use the following to automatically copy your bundle upon creation via `yesod # keter`. Uses `scp` internally, so you can set it to a remote destination diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index aefd5a30a..d6c440632 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -30,9 +30,22 @@ stanzas: - LDAPTIMEOUT - DETAILED_LOGGING - LOG_ALL + - LOGLEVEL + - ALLOW_DEPRECATED - PWFILE - CRYPTOID_KEYFILE - IP_FROM_HEADER + - MAILFROM_NAME + - MAILFROM_EMAIL + - MAILOBJECT_DOMAIN + - SMTPHOST + - SMTPPORT + - SMTPSSL + - SMTPUSER + - SMTPPASS + - SMTPTIMEOUT + - SMTPLIMIT + # Use the following to automatically copy your bundle upon creation via `yesod # keter`. Uses `scp` internally, so you can set it to a remote destination diff --git a/config/settings.yml b/config/settings.yml index 75d5af052..f4602cd0e 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -8,10 +8,31 @@ host: "_env:HOST:*4" # any IPv4 host port: "_env:PORT:3000" ip-from-header: "_env:IP_FROM_HEADER:false" approot: "_env:APPROOT:http://localhost:3000" +mail-from: + name: "_env:MAILFROM_NAME:Uni2Work" + email: "_env:MAILFROM_EMAIL:uniworx@localhost" +mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" +mail-verp: + separator: "+" + at-replacement: "=" +mail-support: + name: null + email: "uni2work@ifi.lmu.de" -detailed-logging: "_env:DETAILED_LOGGING:false" -should-log-all: "_env:LOG_ALL:false" -minimum-log-level: "_env:LOGLEVEL:warn" +job-workers: "_env:JOB_WORKERS:10" +job-flush-interval: "_env:JOB_FLUSH:30" +job-cron-interval: "_env:CRON_INTERVAL:60" +job-stale-threshold: 300 +notification-rate-limit: 3600 +notification-collate-delay: 300 +notification-expiration: 259201 + +log-settings: + log-detailed: "_env:DETAILED_LOGGING:false" + log-all: "_env:LOG_ALL:false" + log-minimum-level: "_env:LOGLEVEL:warn" + +# Debugging auth-dummy-login: "_env:DUMMY_LOGIN:false" allow-deprecated: "_env:ALLOW_DEPRECATED:false" @@ -44,6 +65,19 @@ ldap: scope: "_env:LDAPSCOPE:WholeSubtree" timeout: "_env:LDAPTIMEOUT:5" +smtp: + host: "_env:SMTPHOST:" + port: "_env:SMTPPORT:25" + ssl: "_env:SMTPSSL:starttls" + auth: + type: "login" + user: "_env:SMTPUSER:" + pass: "_env:SMTPPASS:" + pool: + stripes: "_env:SMTPSTRIPES:1" + timeout: "_env:SMTPTIMEOUT:20" + limit: "_env:SMTPLIMIT:10" + user-defaults: max-favourites: 12 theme: Default @@ -53,3 +87,4 @@ user-defaults: download-files: false cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" +instance-idfile: "_env:INSTANCEID_FILE:instance" diff --git a/config/wordlist.txt b/config/wordlist.txt new file mode 100644 index 000000000..c8db40508 --- /dev/null +++ b/config/wordlist.txt @@ -0,0 +1,4096 @@ +freeload +refusing +transpire +bloating +education +sandbag +plow +subdivide +pushcart +certainty +drivable +departure +shortage +never +chip +detonate +swiftly +selective +chef +phrase +pulse +polish +grandly +detached +statute +gratuity +finch +palatable +scoundrel +query +daughter +naturist +sappy +scribble +study +mangy +shore +tartly +favorable +elude +oversight +capital +rummage +sponsor +parchment +matrix +afraid +judiciary +perky +obnoxious +thee +craftwork +overstock +catalyze +croak +museum +proofs +clay +tripod +facial +tiara +parlor +chemicals +tattle +muscular +deputy +onstage +ligament +blame +spelling +reshoot +angles +upward +seltzer +powdery +chrome +monday +trapped +underrate +squash +plop +computing +stoic +subsonic +mortician +lair +apron +pouncing +calculus +deviator +krypton +spinal +graves +plant +droop +powdered +pacify +saddled +caretaker +gear +petunia +perch +ruckus +vengeful +rental +dill +pegboard +rigging +upon +genre +passivism +brook +subscribe +outcast +jargon +crummy +morbidity +deck +humorist +scalded +reassign +carving +cruelty +daffodil +hemlock +fraternal +detection +radiator +despite +manlike +release +iron +deem +jurist +jawless +mumbling +flaky +sequence +casket +grinning +sanitary +retention +reflected +tall +thinness +monument +dayroom +puzzling +jackknife +green +marshland +tumbling +glade +amusable +seldom +tattoo +showing +unit +malt +griminess +radiation +java +unfailing +resource +steadily +cranberry +comrade +cornball +sinless +lecturer +blaspheme +cussed +divisible +variably +emphasis +tiptop +underfed +underfeed +sureness +clang +saturday +blasphemy +tutu +flashback +striving +sandworm +tropics +skies +ritzy +comment +swirl +gambling +koala +unstitch +tainted +manhandle +badly +revocable +spotty +overdress +lapping +woven +smite +movable +sphere +matcher +unbolted +exterior +maimed +navy +ritalin +rocker +class +scary +cactus +area +bobbing +oxford +unbend +untracked +swoop +hypertext +vagabond +jumble +uninstall +creole +tag +elevator +sauna +worried +zippy +muppet +scrawny +payee +cozily +arbitrate +plausible +balcony +sporty +predator +cupbearer +rockstar +unhelpful +legwork +favored +grudging +economist +neatness +lurk +unlisted +showy +overreact +contented +flakily +pastor +petty +overeager +giggly +harpist +purveyor +disallow +penny +everybody +kitchen +etching +amaze +pound +dispose +porous +amperage +eardrum +vegan +frigidly +dreary +grunt +dividable +conical +overblown +dingo +shortcake +dander +obliged +ploy +radiated +everyone +gesture +tying +raging +tinderbox +leverage +cornflake +pointy +garter +lapdog +ashen +impurity +rejoice +ensure +verbose +musky +sudden +proud +amazingly +brunette +trio +handiness +panama +faucet +gangrene +snowfall +stimulant +compound +esteemed +claim +grasp +obsolete +energy +guidable +unshaved +chewy +scarcity +pencil +jaybird +trance +request +easter +little +driller +hanky +reversal +buddy +yoyo +kitty +unsaved +heritage +fabulous +quiver +generous +graffiti +bakery +cackle +utility +untainted +verbally +shut +uninsured +unmindful +protector +swear +wieldable +divorcee +resume +primal +entrust +anew +curtain +storewide +sapling +gluten +outscore +earthly +slinky +barber +plastic +operator +pastrami +porthole +semantic +gaming +shrunk +gangway +grimacing +hypnosis +encrypt +kinetic +grope +professor +decay +tinker +handed +magenta +ascertain +freeware +outbreak +acuteness +suspend +stoneware +litter +buckle +climate +violet +truffle +tubeless +voucher +napkin +cheer +emcee +maritime +deafness +prowess +repose +decoy +tinkling +trifle +citation +collar +audition +operative +marshy +buckskin +zit +undergrad +trapezoid +sphinx +uncured +wafer +floral +footpad +threaten +ouch +bottle +humming +pasty +outpour +phobia +faculty +unsorted +slacker +gravy +darkened +dizziness +equivocal +pedometer +glowing +headphone +stillness +armless +attendee +landscape +worsening +sinister +mobile +header +armoire +washboard +army +massager +revolt +work +spearmint +bullpen +garden +tried +coyness +writing +amply +flounder +armadillo +footbath +sandy +blanching +relive +thigh +barista +setback +mayday +cotton +flagman +unmasking +onward +preview +happier +pantyhose +swooned +thorn +pod +douche +graceless +aflutter +purse +hatching +singer +ecosystem +alone +legend +sprout +wrecker +lyricism +surfboard +icing +preorder +doily +aggregate +bacterium +unflawed +security +nucleus +collide +nutrient +till +boondocks +savings +acutely +overlabor +unlikable +trunks +stapling +awning +finishing +thermos +virtuous +smuggling +immodest +turmoil +console +osmosis +external +drown +acid +tumble +hardening +overact +limb +amigo +guacamole +caption +unmolded +nifty +gas +ibuprofen +smitten +slick +scared +abrasion +squeamish +sprung +unworried +prong +aging +zipping +envoy +oppose +recoup +deforest +railcar +sled +throwaway +canopener +uplifted +spew +widow +freestyle +drove +diagnoses +anthem +food +grass +renewable +cone +majority +footgear +collected +balsamic +facsimile +entity +patronize +hypnoses +reggae +railing +chitchat +acting +oversweet +strewn +nineteen +curtsy +gallantly +item +earpiece +tamper +safari +pampered +radish +operation +ramp +reset +dividing +chatter +tasty +deluxe +caliber +audible +marry +pamperer +upfront +rover +canal +cobweb +uncounted +unpledged +gone +stubbly +catacomb +yesterday +glance +jury +tissue +purple +rants +overgrown +freebase +upper +gleeful +chomp +ramrod +anyway +single +gradually +chaste +vendor +staff +unturned +cannon +approve +urging +wager +treadmill +kick +unwieldy +disk +comma +retype +zookeeper +rotunda +backward +galley +liability +oxidize +smugness +dismay +hexagram +lemon +slacks +onto +provoking +strep +strode +quarry +frosted +bleep +quickness +riveting +knapsack +aliens +relatable +handball +acre +commerce +decathlon +reliable +chowder +rebuttal +ending +gush +roaming +sensually +result +upright +resemble +spendable +postwar +winking +font +appraisal +dried +crust +slot +vaguely +augmented +city +uncolored +slighted +negation +macaroni +margarine +shopping +quartet +cymbal +capacity +stilt +exceeding +slinging +disobey +brownnose +clergyman +purely +upchuck +mammary +yam +concert +facecloth +bagpipe +unquote +exquisite +gutter +sincerity +suitcase +patronage +outsmart +subtype +sarcastic +employed +paltry +mutiny +spore +ferry +fried +amicably +aloe +lure +landmine +tux +decimeter +rift +scoreless +eastward +replica +scabbed +unshackle +glaucoma +partly +clamor +tradition +babbling +engaged +bobcat +bobbed +scuba +author +washhouse +companion +emporium +algorithm +bulk +dice +shone +shock +spilt +buddhist +silver +affected +bleak +rejoicing +superbowl +applaud +peroxide +jukebox +jinx +squint +decency +bagful +kinfolk +ergonomic +attire +giddy +nutmeg +visor +stainless +embolism +slideshow +elective +correct +quartered +whenever +coach +fanning +defame +antitoxic +frenzy +fiddle +lego +skirt +seduce +spotter +aloft +jet +situation +helpful +matador +unfixed +stays +bridged +earmark +dork +skydiver +such +attain +unexpired +maverick +triage +doornail +concrete +flashy +entitle +cake +blinking +cofounder +denote +dedicator +smooth +twenty +rockfish +spring +stardust +proactive +expansive +skeptic +emboss +imaging +waggle +scooter +apple +drone +debrief +recount +thespian +plug +lance +caboose +congress +data +shifting +renderer +earlobe +stiffness +voyage +dominoes +tractor +maroon +astound +broiling +clinic +deranged +verify +baguette +enchanted +commodity +laborious +olympics +battering +shrewdly +calculate +espionage +frustrate +gamma +compile +scenic +licking +jaundice +relieving +expiring +available +contusion +habitant +finless +alkaline +upheaval +duress +yelling +headscarf +wooing +riveter +carnivore +oversized +fragment +dispersed +eliminate +giver +chubby +tablet +morse +tightly +dictate +suing +pleading +mullets +probe +reshuffle +retract +supply +haven +unbraided +clarinet +cylinder +consult +tweed +tinwork +pushup +whimsical +salary +putt +sensuous +platypus +distant +luminance +oppressed +reply +ridden +dubbed +kennel +mocha +trapping +refrain +repaint +switch +google +traps +deflected +gander +relative +gumball +willfully +unpaid +random +slingshot +connected +equate +majorette +hesitate +canola +causation +mortify +backyard +finite +scoff +cavalier +hardwired +riches +erasure +arise +primarily +wriggly +unrest +coming +appealing +overbuilt +skimmer +coma +flatware +usage +flatworm +silica +ninth +sandlot +dinginess +doorway +womanlike +outer +tiling +pentagon +strangely +sandbar +corner +dreadlock +moonlight +dean +chop +garbage +surgical +rescuer +decline +slider +abstract +pronto +reexamine +improper +subsoil +antihero +freeing +sacrament +encroach +abnormal +cheese +grandpa +monstrous +kinsman +conjoined +padding +flypaper +vanilla +only +volley +mustard +predefine +chaos +ferocity +undamaged +splashed +affair +careless +zigzagged +facility +shun +refinish +nutlike +clause +dock +bulldog +grafting +dress +untamed +cheating +willing +ecosphere +excluding +yeah +residence +thrive +alive +sultry +persuader +projector +esquire +huntress +pesticide +retreat +sports +irrigate +chasing +scrabble +unselfish +cognitive +washer +grumpily +exhume +trident +unfreeze +accent +sterility +unenvied +impaired +frail +flyable +parakeet +outright +translate +bats +triceps +jolliness +extradite +sandstone +deserve +matchbox +bargraph +spectacle +implosive +goldsmith +chatting +ship +haphazard +uncooked +wizard +oops +blurb +sessions +dexterity +viability +nail +grief +suburb +statue +trimester +shanty +clarify +aware +caregiver +starving +footsie +sneeze +excursion +clanking +unstaffed +confiding +flatfoot +confidant +registry +emptier +array +unelected +flatness +emblem +yearbook +canon +gallon +example +plaster +unkind +grudge +tweezers +surname +preplan +ivory +undead +unafraid +zone +brim +hatchery +rimless +ravage +remark +kabob +twisting +juncture +residue +almanac +yearling +gab +sizzling +livestock +wharf +trading +wagon +divided +tanned +visibly +recycling +unease +isolated +maximize +employee +party +tusk +gift +passion +marital +cane +reheat +cost +ground +emote +flyer +carried +chair +violator +prototype +cozy +thousand +placard +umbrella +starship +unclothed +legal +backspin +handwash +delicacy +shrapnel +kangaroo +registrar +evaluate +shelter +premises +primer +hacked +fountain +creed +throwing +friday +robin +editor +gainfully +sanctity +given +chirpy +coliseum +rewind +atlantic +flagstick +definite +fever +rumbling +anatomist +straw +studio +gizmo +proofread +impotency +unhappily +devalue +rectangle +groove +icy +salaried +snort +fit +thaw +shorthand +broadways +shortness +shape +tackiness +chute +stiffly +twiddling +crafty +affirm +paddling +water +hardly +cinnamon +slate +mundane +sift +halved +prism +gills +jubilant +carload +difficult +profile +reuse +swagger +broken +monopoly +spoof +riot +giant +passover +curing +august +cartoon +scorch +chuck +varying +germicide +tribute +copier +clubbed +ointment +ricotta +previous +mutt +turtle +astride +unspoken +unjustly +washtub +cresting +pantomime +frostily +skimming +semester +generic +excavate +decidable +stank +vanquish +stack +reverend +pasted +curve +spindle +ashy +runaround +couch +sniff +untimely +traverse +carless +fragrance +affecting +reemerge +roundish +olive +snowy +hazily +aqueduct +carwash +revoke +chamomile +veteran +pacifism +stress +thing +stereo +excavator +whacky +aneurism +dreamily +erratic +untie +grid +repurpose +cleaver +sprig +unseeing +lid +lapel +headlock +untoasted +heading +sandblast +commence +docile +skincare +retaining +crewman +tycoon +sneezing +crazily +roundness +justly +portable +peculiar +amplifier +cloak +smoked +anemia +anaerobic +majestic +puritan +creasing +gladiator +catfish +echo +safeness +turbojet +engraver +disarm +football +elitism +playmate +sharpie +carnation +rubbed +daycare +penpal +eject +amniotic +kinship +buffer +uncertain +document +clumsily +vintage +engaging +sloppy +tidbit +unrevised +cough +qualified +transform +chest +unnoticed +excitable +mowing +thicket +superglue +sanitizer +vagrancy +sleek +aghast +refresh +constant +shown +mothproof +periscope +parachute +kebab +improvise +vacancy +jackal +unburned +nebula +deviation +script +trilogy +jittery +siamese +rinse +jazz +subpanel +expert +illicitly +spent +staleness +rebate +opulently +elastic +poplar +clapper +grime +scraggly +subdued +repugnant +fax +net +tricky +presoak +neutron +expectant +crisply +caramel +simile +duller +fidelity +press +armed +reliance +arrange +happy +corporate +perpetual +hatless +creamer +joyfully +wimp +quickly +easing +cold +mortally +flashing +spool +varied +distrust +squirt +buffing +praying +hug +oversold +dwelling +cuddle +wanted +mumble +crowbar +paying +joylessly +outlook +setting +sabotage +dismantle +prudishly +marbled +sadden +equipment +musty +litigator +evaporate +prologue +crazy +judicial +perjury +ankle +palm +uncurious +grappling +move +pandemic +dingbat +mongrel +eligible +brunt +glacial +hurry +guiding +january +jokingly +cheesy +yogurt +vertical +bluff +starved +fancied +mothball +playback +overrun +exorcism +overbid +next +giblet +nest +darwinism +spotting +doorbell +subtly +scruffy +overview +uncouth +map +gleaming +siren +october +scallop +nastiness +snowless +citrus +squiggly +daylight +epidermis +cope +skittle +deviant +grinch +antonym +ceremony +snare +lunchbox +gothic +exporter +endpoint +ideology +mule +unaware +unwelcome +provider +dirtiness +taunt +wreath +facedown +violation +detract +mutilator +gizzard +perceive +railroad +marbles +playhouse +backdrop +maggot +sherry +gnat +plural +backpedal +gloating +gorged +matriarch +spooky +proving +snide +deity +contour +venomous +liking +upstate +niece +robbing +foam +finally +bannister +tasting +oozy +overstay +spearhead +stubble +salute +herald +unwitting +plating +strobe +curled +constrict +ahead +uncoated +underwent +barley +jugular +unbridle +hamburger +stumbling +drainer +wow +hurt +extortion +glorified +gating +scientist +occupancy +buckwheat +prelaunch +vigorous +twerp +passcode +tavern +amuser +dizzy +try +crease +darkening +flattery +gestation +coauthor +activism +evasion +capped +shame +turkey +sarcasm +grandma +squeezing +nickname +resigned +handsaw +gem +upgrade +retool +plank +clavicle +afflicted +line +guru +unsheathe +resisting +replace +lumping +bagginess +unlawful +defender +womanly +crudeness +smugly +blunderer +freeness +tightwad +answering +challenge +thievish +purging +component +favoring +bullseye +tibia +trillion +lubricate +mural +unroll +applicant +devourer +job +sinner +hypnotize +valley +dugout +shrill +paralegal +cycling +backlands +down +saucy +pusher +cubbyhole +consuming +growing +grumbling +tuition +film +amount +powdering +reptile +sprinkled +kerchief +coastal +autistic +calamity +glucose +unimpeded +submarine +starboard +styling +envision +yen +cabdriver +pardon +scroll +directive +balmy +timing +linseed +unglue +aide +specimen +untying +viper +leggings +vindicate +uptown +recent +junkman +freefall +slip +petal +saddlebag +hurried +early +coat +rockslide +tricycle +grab +crusader +bucked +washroom +skinless +deduct +maternity +entwine +squishier +spoiled +hatchback +dragging +preamble +snowdrift +designate +panda +surplus +pueblo +endless +unmapped +reconcile +blazing +glove +unclad +slander +snap +feline +overthrow +research +shrubs +landfill +liqueur +mankind +suave +absolve +gender +define +strangle +relocate +credibly +apprehend +fifth +confound +sagging +imperial +tributary +grub +urethane +parsley +geranium +overflow +return +subsector +ultra +dowry +levers +sculptor +accustom +headrest +stout +eats +overcome +unsubtle +negligee +unstopped +trombone +agnostic +haggler +unpaved +strike +untaken +ageless +unstable +cruncher +deftly +culpable +ashes +reproach +navigator +tipoff +evasive +removing +blurt +whoops +dropout +aground +curable +pureblood +john +various +baking +lunchroom +frigidity +amiable +refreeze +unequal +karaoke +jumbo +suspect +celtic +stopper +passably +rascal +legged +tapering +puppet +prompter +hunchback +padlock +storeroom +briar +squad +spied +negotiate +traffic +unstylish +amplify +granny +subwoofer +angled +stroller +paced +flanked +swinging +shelving +streak +gown +collie +badass +spirited +hydrogen +underpaid +polar +dallying +armband +frolic +ventricle +affront +cure +grating +keenness +tabasco +depraved +manhood +dispute +implosion +jailhouse +aversion +shrank +sulk +nearest +outboard +size +reversing +almost +unshaken +encircle +stipulate +rocky +arson +endurance +suction +walmart +juggle +hurled +capable +mountain +calm +goggles +bulgur +studied +obtrusive +ninetieth +dwarf +doctrine +quilt +outward +automated +issue +saline +motivator +overfill +dynasty +yo-yo +resistant +dove +brunch +rendition +freebee +exorcist +moonscape +embargo +oversleep +tidiness +ammonia +predict +rely +huntsman +manager +relock +detergent +seizing +enactment +obstacle +divinity +trash +capsize +untagged +blend +panning +anagram +anymore +stratus +engulf +empathic +antacid +dime +handwrite +lustrous +lifting +mug +elevating +bungee +squeeze +broiler +spyglass +curly +exerciser +outmost +corroding +uneatable +bullish +defeat +isotope +rule +sitting +narrow +mortified +average +applied +pecan +reprocess +spearfish +captive +mortality +dreamless +disdain +daylong +boat +caddy +swarm +pavilion +bush +respect +swimwear +errand +truce +unlined +blemish +explicit +glutinous +casually +nursing +preschool +posting +monogamy +selector +purifier +trench +escapist +aged +hurler +unedited +acrobat +unpinned +walrus +monotone +theater +tarmac +volumes +pushiness +reapprove +cryptic +used +chaplain +hurricane +harmonics +womanhood +sensitive +gotten +dweeb +borrower +prevalent +agent +hungrily +unread +truth +salsa +dynamite +exuberant +bazooka +draw +scolding +uncaring +frame +spud +polygon +unwary +waking +hurdle +repeated +backspace +dodgy +unadorned +property +rehab +headgear +family +raking +rimmed +unclip +matter +coveted +ambitious +prewar +cautious +bulge +auction +jockstrap +demystify +grader +pawing +aptly +throttle +jogger +stylized +crystal +ascent +evict +trough +unvaried +stark +overtime +unsold +cradle +ambition +satin +album +wrinkly +bullion +coziness +awoke +district +unaired +entertain +dramatic +hyperlink +flyover +yin +revert +scavenger +batboy +legislate +recollect +stamina +driving +old +kosher +protract +dole +cradling +flavored +aspirin +ladies +affluent +abiding +overturn +undermine +science +disperser +dilute +uncork +change +synopsis +silenced +falsify +flint +consonant +rewash +peso +secular +reseller +annotate +overripe +slam +scheme +unlaced +knickers +jogging +ditch +corridor +chase +petted +molehill +user +radar +petition +census +reborn +exalted +graveyard +congenial +dreadful +budding +capably +wand +pulp +childless +most +splendid +module +outsider +stoppable +stick +hydroxide +snaking +reconfirm +version +unsworn +cornbread +stride +tables +cusp +remarry +robust +stooge +elevate +numbly +diminish +severity +blissful +chunk +litmus +glowworm +rented +handoff +eatable +spouse +sustained +disband +greedy +exchange +harmony +annually +hate +spousal +drop-down +shadiness +gecko +broaden +acorn +skeleton +sturdily +doorpost +persuaded +shortcut +agency +repulsive +spiny +outcome +boasting +swept +neglector +halogen +exes +supremacy +crescent +phoney +unabashed +rink +sandpit +cacti +stylishly +jingling +art +heat +basics +stem +riddance +covenant +nanometer +keg +dinner +reviver +nicotine +dandy +caucus +euphemism +shortlist +turbofan +gulp +mummify +decal +trace +drapery +survey +boxing +subarctic +nearby +lividly +dreaded +constable +duly +wobble +handprint +disorder +camcorder +composite +handshake +purplish +growl +janitor +boundless +immovable +uninjured +stopping +disloyal +poster +heaving +avoid +resize +gopher +coveting +overpass +jelly +duration +galvanize +fantasy +aim +crisped +molecular +carpentry +debit +awkward +skinny +celestial +overlook +numerator +running +ashamed +amber +hyphen +luster +clock +bronzing +punctured +pretended +curvy +detective +twitter +tiptoeing +legwarmer +corsage +tadpole +flaxseed +buggy +obligate +handset +irritant +nugget +sheep +marina +alongside +unlocked +humiliate +viewless +outing +skewer +capsule +reversion +regally +threefold +preheated +resilient +carport +suggest +commotion +deflator +displease +settle +anger +unsteady +unmoral +cleat +squabble +decompose +brush +fondling +perish +wobbling +revival +dosage +disparity +brussels +boots +civil +container +shed +raft +cheddar +bride +mousy +wildfire +dude +rejoin +resonant +passenger +customary +outweigh +degrease +delusion +encore +declared +uncurled +implicate +unpack +hybrid +twitch +penholder +exclusion +outmatch +onboard +knee +epidemic +tubular +flier +silicon +creation +fantastic +glorify +worrisome +glaring +stabilize +ungraded +voicing +unlivable +demotion +sacrifice +animal +freeway +motto +smuggler +utopia +gulf +passive +reclaim +aflame +heave +septum +safely +cramp +emotion +hunk +retouch +equation +catsup +brisket +condition +numerous +porridge +backtrack +synthetic +steep +surfer +busybody +ripening +bath +blurry +bouncing +ample +catapult +tactile +surpass +bartender +antler +cobbler +arming +envelope +undrilled +clamp +direction +syndrome +setup +charbroil +yoga +shaking +chastise +coeditor +overpower +cover +frisbee +venture +duplicate +scalding +coconut +clutter +eggnog +gumdrop +sectional +prissy +hammock +tipping +ethanol +deskbound +suitable +symphony +clustered +pupil +cobalt +path +credit +unlighted +backstab +gigabyte +startle +eclipse +snorkel +shimmy +ozone +compel +cardboard +bodacious +slush +submerge +embody +concerned +mandate +surgery +relapsing +hula +length +greeter +spherical +lugged +slouchy +unknowing +quaking +prude +subtitle +manual +maternal +chaps +surprise +manhole +cache +handgrip +footwork +attention +detoxify +clobber +turret +barge +smolder +parasite +feel +opposing +deplored +ruse +guide +unlatch +posted +crumb +portion +smartly +purify +unworn +tapioca +snowbound +cheek +enforced +badness +breath +maximum +control +backing +shank +shrouded +circulate +remedy +shakily +creamlike +blubber +fragrant +panhandle +sesame +importer +spoiler +glitch +caterer +uncanny +diary +florist +surely +shortwave +blinks +smudgy +zesty +genetics +unloader +obstinate +perfected +profanity +tapestry +footless +cursor +these +spoils +wrongly +onset +defraud +unfiled +struck +coronary +disengage +heavily +slaw +dorsal +clunky +dawn +lip +throng +service +hatbox +dastardly +eastcoast +ragweed +squall +groggily +cushy +carnival +nullify +subtotal +scrubbed +debate +unison +shine +prescribe +reformist +jiffy +fondness +preformed +napped +overhaul +claw +ellipse +cruelness +hardener +carpool +unglazed +uniformly +unmanaged +enclose +viewable +fastball +drainable +exemplify +lens +implement +splurge +unhidden +imply +survival +cricket +cringe +usual +capture +automatic +glimpse +visitor +hatchet +unthread +egomaniac +fifty +fox +resident +hangup +wisdom +sneak +configure +depletion +eccentric +sly +disinfect +backlit +mummified +kimono +voltage +rewrap +gazing +swoosh +ribbon +pliable +expedited +slouching +national +bolster +steerable +backshift +smog +earthlike +mulled +arrogance +reclusive +essay +oxidant +moustache +goes +sludge +tightrope +washable +unwanted +bogged +wreckage +precut +implant +dumpling +dreamboat +tracing +promoter +dipper +fracture +attempt +seismic +extending +eldercare +coastline +garnet +democracy +boil +magical +cupcake +finance +irritable +synergy +coherence +dealt +collage +foe +pacifier +bobtail +unblessed +chamber +activity +pacific +striking +oblong +endorphin +handpick +smartness +cosmos +radio +ladylike +prize +sitter +estimator +prone +childish +refinery +cod +untrimmed +earplugs +afterlife +unearth +confusion +stability +arousal +stuffed +regular +remedial +enlarged +unvented +phrasing +gristle +moonrise +bunch +motocross +defrost +untangled +quintuple +cedar +unlovable +reverence +parking +clover +depose +resample +recreate +feast +overbook +reattach +purebred +hence +gallery +yonder +unshipped +finicky +pushover +gratified +attic +ipad +shining +barstool +undertow +pronounce +nimbly +relay +headway +mannish +secluded +populate +cosigner +cathedral +unreeling +skintight +landlord +falcon +snuggle +sandbox +ream +disbelief +roman +pendant +timothy +calcium +crablike +kindle +lint +sculpture +eraser +limeade +arrival +nastily +agonizing +salutary +enroll +swivel +darn +confined +frugality +enticing +giddiness +pouring +avatar +swell +humility +deception +liberty +flatterer +peddling +junior +rebuild +diffuser +unloving +napping +unholy +unwatched +reunion +refried +evident +dumping +mockup +shaft +construct +linked +posture +pranker +equal +stargazer +ravioli +gerbil +headwear +guzzler +refute +shale +overbite +contort +headpiece +morality +malformed +kleenex +clumsy +pouch +mower +alias +driveway +trailing +unskilled +commode +quotable +mournful +huddle +ammonium +worshiper +masses +debating +ride +unseemly +stunt +spry +itinerary +glamorous +bagged +stoplight +zeppelin +unbundle +granular +humid +repeater +garland +battalion +luridness +plod +untruth +glorious +widen +reoccur +subprime +boring +reaction +pond +pox +itunes +shampoo +speller +datebook +blot +racism +labrador +pelvis +casino +handmade +mocker +lively +operating +vividness +thumb +outshoot +preset +penknife +twig +glider +versus +childcare +motivate +zoning +halves +oval +jam +slashed +wrench +squeegee +steering +dragster +fiction +cranial +feeble +chewing +splinter +vineyard +rearrange +clarity +marathon +exponent +prideful +zebra +shelve +prominent +leotard +drainage +snack +gravel +remix +nearly +ooze +prognosis +march +mosaic +simple +delirium +recall +apostle +schilling +kissing +wistful +aqua +grip +outwit +dazzling +gigantic +criteria +gibberish +fanciness +ripping +unplug +washing +luckily +dragonish +rotting +neuter +corrosive +shopper +cornea +dumpster +delivery +trophy +library +shrink +bully +target +wincing +duvet +iphone +retread +bounce +filler +presume +landlady +portly +upstream +disrupt +steadfast +undone +tarnish +politely +sixtyfold +sensation +scant +clique +consumer +unopened +bleach +happily +zombie +composed +overlap +sway +scotch +embattled +frequent +canyon +barrier +acquire +debtor +kisser +aviation +rearview +skied +appendage +maybe +derby +disgrace +wolf +overhand +those +dazzler +spoiling +reentry +tiny +bullfight +washout +renewal +venus +pushy +tuesday +avalanche +bubble +uncheck +uniformed +unwilling +zealous +blighted +lanky +delta +dolphin +prorate +snowplow +relish +sliding +swan +unselect +subplot +stung +nag +pessimist +relight +moonbeam +sighing +extended +rebound +sleep +foothill +ended +prancing +clench +coil +erupt +outlying +dating +ipod +lilly +lukewarm +cadet +equity +uptake +lash +flaring +copied +exclaim +bash +sulphuric +backstage +unwired +siesta +pursuable +stash +improve +marlin +imagines +saggy +ice +tacking +scribing +unpaired +abstain +stimuli +scone +banshee +unmoved +patient +yield +yapping +satisfied +sardine +kettle +riverboat +subheader +pushpin +juggling +reconvene +poise +uncouple +gathering +frisk +dissuade +elite +bagel +wake +disarray +overkill +aids +evaluator +mummy +drinkable +tropical +vitalize +exact +concave +boss +goatskin +crummiest +wages +wielder +avid +mouth +caress +professed +barbecue +paper +everglade +dealmaker +dedicate +paprika +lethargy +haunt +tribune +enviable +hydration +stretch +baked +uncombed +doorframe +harness +aorta +freemason +trousers +cupid +catering +femur +wrongful +pout +departed +sequel +surface +regime +rename +festival +wish +stage +gloater +unleash +transpose +drench +commuting +affix +occultist +stunning +partridge +sanded +sublime +spoken +slimy +grieving +unframed +lining +remember +utilize +skater +mastiff +trowel +renewed +monologue +carpenter +gargle +undergo +hardship +crayfish +condiment +frayed +unretired +hatred +another +almighty +astronaut +domelike +ramble +clash +barometer +jalapeno +carol +abroad +panorama +stonewall +scouts +destruct +unengaged +runt +defense +sweep +backlog +dairy +deceptive +luncheon +rubbing +slapstick +ranking +graceful +slackness +brink +senator +remindful +bunkbed +untrue +roulette +taekwondo +santa +unsmooth +scholar +blaming +fragile +abridge +moistness +from +manor +outburst +stadium +twentieth +staunch +epiphany +keep +unrivaled +reverb +twiddle +justifier +removal +flavoring +tranquil +lumpiness +object +unrobed +stuffing +curse +pelican +decade +travel +theme +attach +ought +during +repressed +smokiness +washbowl +ethics +connector +scoring +trusting +prozac +dismiss +varmint +resort +licorice +spectrum +enviably +harmonica +undefined +anatomy +baggie +earthen +plaything +deluge +savor +hydrated +filth +reselect +jaywalker +jeep +backup +matted +excretion +blooper +riverbank +sediment +catwalk +scurvy +chess +pelt +barbed +edging +gilled +provoke +statistic +reforest +doorstep +unethical +cartload +dollhouse +churn +junction +whiny +ablaze +recant +canister +mama +nativity +facebook +federal +corral +unsealed +squatting +entail +estate +confusing +eligibly +cabbie +browsing +arrogant +boxer +unmatched +semisoft +dental +enslave +yummy +onyx +henchman +veggie +glutton +chariot +playful +racoon +garlic +skating +denture +elbow +reanalyze +mashed +faceless +avert +shorts +operable +denial +asparagus +certainly +domain +unbiased +earmuff +subsiding +mushiness +patchwork +playgroup +petroleum +backside +gaffe +trembling +magnifier +similarly +untrained +parade +parcel +cider +uncorrupt +wronged +much +unmanned +mushroom +snitch +semicolon +dealer +parting +recital +congrats +anchovy +curfew +excusable +gnarly +breeching +paramedic +zips +swampland +exemption +absinthe +simplify +thwarting +stole +reenter +manmade +overstep +concur +rural +varsity +trustless +salvage +hardiness +armchair +handling +reporter +cannabis +thermal +degree +imprecise +semifinal +flammable +factor +unrushed +ruby +spleen +starless +observing +ember +sullen +undertake +golf +safeguard +duke +spinout +transfer +linguini +pregnant +stupor +unfrosted +prewashed +cranium +sixfold +lucid +chapped +enjoyably +privatize +blooming +boozy +earphone +armrest +affidavit +distance +unisexual +posing +humbling +chapter +partner +shrine +imitation +retinal +pension +vivacious +drift +substance +nutshell +disparate +referable +residual +catching +manliness +fidgeting +hazing +easiest +lather +hunger +stomp +emperor +overboard +humorless +stand +although +polygraph +shimmer +illusion +oblivion +anybody +amuck +coroner +probation +unwed +revisit +gallows +shaky +liable +tactful +pettiness +satchel +sandstorm +retiree +deuce +enlarging +tabloid +crunchy +plexiglas +slept +pyramid +massive +snowman +thrower +deceit +grout +guy +outshine +agenda +regress +cape +synthesis +unleaded +oboe +empirical +turban +popular +swapping +mating +flight +manned +mollusk +renounce +fringe +mandolin +scorpion +dealing +stony +tingle +curler +unmarked +imitate +gurgle +haiku +privacy +vowel +treat +kiln +dispersal +unfocused +duckbill +reunite +mustiness +wispy +botany +hazard +compactly +confident +resupply +unbroken +repent +laziness +undivided +recoil +unhook +swinger +gumming +monoxide +policy +thirsting +bankbook +diagram +cardigan +headfirst +kindred +dimly +banking +angler +imprudent +second +cupping +crewless +numbness +geriatric +cosmetics +poncho +handful +payable +twirl +commute +overexert +cocoa +screen +uncle +borough +untreated +designer +doorknob +wildcat +shout +veneering +parrot +french +slang +borax +trailside +untapped +student +obituary +tarot +prowling +scam +splatter +suffrage +mayflower +wasp +paralyze +radiance +overlay +mystify +sternness +rash +candied +sulfate +remold +protozoan +banker +cubical +antarctic +carnage +marrow +endanger +divisibly +gloomy +wildland +legume +earthling +pureness +eggplant +broadcast +uncut +duplex +deport +diving +borrowing +plot +cultivate +widely +plutonium +hypocrisy +splashy +gently +refill +salad +drizzle +visiting +silk +deeply +outflank +revered +eel +likely +saloon +blast +graveness +stock +overuse +lapped +sincere +private +kilometer +pectin +manpower +regroup +grill +preteen +froth +nuptials +unsnap +payroll +bony +detail +cameo +crispness +crested +rope +until +refund +record +duffel +annex +duo +subsystem +neurosis +rebel +latter +dining +tartar +upcoming +creamed +unsubtly +creative +acetone +immerse +grazing +steam +lushness +track +crook +native +cucumber +shallow +sulfur +unloved +upturned +reliably +stinking +desktop +blandness +scabby +gurgling +purposely +likewise +giddily +reapply +resurrect +untold +paralysis +sprawl +defile +unhearing +degrading +wilt +outfit +recognize +that +street +subside +dormitory +jaws +curling +evade +amid +stricken +stellar +unheated +emerald +juror +entangled +clatter +unloaded +gestate +throbbing +unclamped +symphonic +lunchtime +morale +ungloved +playlist +husked +laundry +breeze +fleshed +poppy +tackling +laborer +product +issuing +unscathed +goldfish +stinky +persevere +flick +lard +stallion +race +imposing +subfloor +finisher +gooey +blah +twisted +swimsuit +ungreased +catchy +putdown +unhappy +unheard +eastbound +coasting +reptilian +plethora +clerk +shindig +slighting +thesis +utmost +dividers +unwoven +cupped +plausibly +deploy +ebay +underwire +aeration +pried +drowsily +agony +untitled +vocally +diffusion +disposal +sputter +life +cubicle +scarring +sinuous +dividend +glitzy +blush +popper +quadrant +throwback +tinsel +maturity +unfold +twice +freedom +ribcage +fence +eleven +providing +platform +upheld +submersed +slab +bundle +villain +front +relic +muzzle +removable +demeanor +tilt +clamshell +daytime +headsman +cornfield +nutcase +excusably +numeric +worst +banana +exploit +preface +kerosene +prankish +chill +resurface +eloquence +hardcore +stardom +reflux +edition +outspoken +copilot +scion +retrieval +hash +wick +expansion +outnumber +context +regalia +bouncy +epic +vanish +pacemaker +hertz +serotonin +output +trimness +unworldly +pasture +monthly +cornmeal +outgoing +landing +cavalry +rebuilt +phosphate +duh +urchin +monorail +boned +smoking +finalist +dolly +thank +overdrive +presuming +passing +tyke +cottage +antiques +curdle +thumping +cut +tremor +headroom +charging +festivity +sample +chewer +wool +virtual +fetch +kindness +fancy +residency +unharmed +bountiful +strive +strung +elope +capillary +morphing +ogle +celibacy +vaporizer +reshape +fraction +ascension +mangle +bonehead +recolor +doorstop +quail +strudel +frighten +repost +swimmer +securely +devotion +pavement +hardhead +unrated +broadband +wiring +closure +retrace +customer +deprive +repackage +agile +girdle +saga +crank +lung +headstone +filing +skeletal +felt-tip +country +botanist +purgatory +copper +tamer +monsieur +unscrew +wheat +confider +jaunt +reviving +unfazed +ajar +eating +sprint +colonist +reps +gyration +brigade +tingly +pyromania +harbor +mumbo +catatonic +shove +whoopee +straddle +exfoliate +dictation +coaster +oxidation +aside +tiger +cancel +aspect +playable +rebuff +rebalance +embroider +empty +mounted +outfield +scale +preachy +exert +sedate +award +retired +confused +sterilize +computer +unleveled +yarn +recapture +renovator +evacuee +utensil +bobble +starlet +kilowatt +shirt +living +powwow +darkness +roster +lagoon +rematch +edge +hunting +pampers +coagulant +overture +custard +murkiness +parabola +bronze +causing +abide +unreal +untwist +hankering +upbeat +crimp +reputably +procedure +deflation +figment +trump +botch +unmade +gimmick +opponent +counting +overeater +bulginess +neatly +sworn +spoon +richly +comic +hush +perm +discover +skimpily +unsettled +cycle +drastic +hardcopy +spirits +ounce +undertone +canary +pebble +reprogram +boggle +diligence +composure +perfectly +atypical +rotten +matchbook +attentive +payday +pushchair +rise +huskiness +appointee +courier +cognition +coke +fiftieth +spur +audience +flashcard +lyrics +regulator +diabetic +limelight +craziness +unmixed +popcorn +manly +camisole +thimble +boxy +dipping +glory +evergreen +shady +umpire +subtext +division +gong +resonate +endocrine +italics +uneasy +valium +doze +polymer +handler +fame +disjoin +unviable +talisman +reabsorb +magnetize +purge +habitual +angling +plenty +identify +kindly +fritter +cornstalk +veal +upwind +craving +rut +oink +uncross +sizing +favorite +purist +vaseline +quicken +expand +daredevil +jersey +unbitten +catty +playmaker +multitude +spruce +barrette +cesarean +profusely +luminous +fled +faceplate +talcum +mace +chewable +swifter +jasmine diff --git a/db.hs b/db.hs index 3bb77bcf5..e2d130fe7 100755 --- a/db.hs +++ b/db.hs @@ -1,11 +1,12 @@ #!/usr/bin/env stack --- stack runghc +-- stack runghc --package uniworx {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) @@ -20,6 +21,8 @@ import System.IO (hPutStrLn, stderr) import qualified Data.ByteString as BS +import Database.Persist.Sql (toSqlKey) + import Data.Time @@ -62,6 +65,8 @@ fillDb = do AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings now <- liftIO getCurrentTime let + insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r) + insert' = fmap (either entityKey id) . insertBy summer2017 = TermIdentifier 2017 Summer winter2017 = TermIdentifier 2017 Winter summer2018 = TermIdentifier 2018 Summer @@ -78,6 +83,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["en"] + , userNotificationSettings = def } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -92,6 +99,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -106,8 +115,10 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } - void . insert $ User + maxMuster <- insert User { userIdent = "max@campus.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing @@ -120,6 +131,8 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } void . insert $ User { userIdent = "tester@campus.lmu.de" @@ -134,8 +147,10 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userMailLanguages = MailLanguages ["de"] + , userNotificationSettings = def } - void . insert $ Term + void . repsert (TermKey summer2017) $ Term { termName = summer2017 , termStart = fromGregorian 2017 04 09 , termEnd = fromGregorian 2017 07 14 @@ -144,7 +159,7 @@ fillDb = do , termLectureEnd = fromGregorian 2018 07 14 , termActive = False } - void . insert $ Term + void . repsert (TermKey winter2017) $ Term { termName = winter2017 , termStart = fromGregorian 2017 10 16 , termEnd = fromGregorian 2018 02 10 @@ -153,7 +168,7 @@ fillDb = do , termLectureEnd = fromGregorian 2018 02 10 , termActive = True } - void . insert $ Term + void . repsert (TermKey summer2018) $ Term { termName = summer2018 , termStart = fromGregorian 2018 04 09 , termEnd = fromGregorian 2018 07 14 @@ -162,22 +177,28 @@ fillDb = do , termLectureEnd = fromGregorian 2018 07 14 , termActive = True } - ifi <- insert $ School "Institut für Informatik" "IfI" - mi <- insert $ School "Institut für Mathematik" "MI" - void . insert $ UserAdmin gkleen ifi - void . insert $ UserAdmin gkleen mi - void . insert $ UserAdmin fhamann ifi - void . insert $ UserAdmin jost ifi - void . insert $ UserAdmin jost mi - void . insert $ UserLecturer gkleen ifi - void . insert $ UserLecturer fhamann ifi - void . insert $ UserLecturer jost ifi - sdBsc <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) - sdMst <- insert $ StudyDegree 88 (Just "MSc") (Just "Master" ) - sdInf <- insert $ StudyTerms 79 (Just "Inf") (Just "Informatik") - sdMath <- insert $ StudyTerms 105 (Just "M" ) (Just "Mathematik") + ifi <- insert' $ School "Institut für Informatik" "IfI" + mi <- insert' $ School "Institut für Mathematik" "MI" + void . insert' $ UserAdmin gkleen ifi + void . insert' $ UserAdmin gkleen mi + void . insert' $ UserAdmin fhamann ifi + void . insert' $ UserAdmin jost ifi + void . insert' $ UserAdmin jost mi + void . insert' $ UserLecturer gkleen ifi + void . insert' $ UserLecturer fhamann ifi + void . insert' $ UserLecturer jost ifi + let + sdBsc = StudyDegreeKey' 82 + sdMst = StudyDegreeKey' 88 + repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) + repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) + let + sdInf = StudyTermsKey' 79 + sdMath = StudyTermsKey' 105 + repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik") + repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut") -- FFP - ffp <- insert Course + ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -186,7 +207,7 @@ fillDb = do , courseSchool = ifi , courseCapacity = Just 20 , courseRegisterFrom = Just now - , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) + , courseRegisterTo = Just (nominalDay `addUTCTime` now ) , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True @@ -196,14 +217,14 @@ fillDb = do void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp - sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) + sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) + sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) + sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions insert_ $ SheetEdit gkleen now sheetkey -- EIP - eip <- insert Course + eip <- insert' Course { courseName = "Einführung in die Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -218,10 +239,10 @@ fillDb = do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now eip - void . insert $ DegreeCourse eip sdBsc sdInf - void . insert $ Lecturer fhamann eip + void . insert' $ DegreeCourse eip sdBsc sdInf + void . insert' $ Lecturer fhamann eip -- interaction design - ixd <- insert Course + ixd <- insert' Course { courseName = "Interaction Design (User Experience Design I & II)" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -230,16 +251,16 @@ fillDb = do , courseSchool = ifi , courseCapacity = Just 20 , courseRegisterFrom = Just now - , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) + , courseRegisterTo = Just (nominalDay `addUTCTime` now ) , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ixd - void . insert $ DegreeCourse ixd sdBsc sdInf - void . insert $ Lecturer fhamann ixd + void . insert' $ DegreeCourse ixd sdBsc sdInf + void . insert' $ Lecturer fhamann ixd -- concept development - ux3 <- insert Course + ux3 <- insert' Course { courseName = "Concept Development (User Experience Design III)" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -254,10 +275,10 @@ fillDb = do , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ux3 - void . insert $ DegreeCourse ux3 sdBsc sdInf - void . insert $ Lecturer fhamann ux3 + void . insert' $ DegreeCourse ux3 sdBsc sdInf + void . insert' $ Lecturer fhamann ux3 -- promo - pmo <- insert Course + pmo <- insert' Course { courseName = "Programmierung und Modellierung" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -284,6 +305,7 @@ fillDb = do , sheetVisibleFrom = Just now , sheetActiveFrom = now , sheetActiveTo = (14 * nominalDay) `addUTCTime` now + , sheetSubmissionMode = CorrectorSubmissions , sheetUploadMode = Upload True , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing @@ -297,8 +319,14 @@ fillDb = do void . insert $ SheetFile sh1 h102 SheetHint void . insert $ SheetFile sh1 h103 SheetSolution void . insert $ SheetFile sh1 pdf10 SheetExercise + -- + sub1 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing + void . insert $ SubmissionEdit maxMuster (nominalDay `addUTCTime` now) sub1 + void . insert $ SubmissionUser maxMuster sub1 + sub1fid1 <- insertFile "AbgabeH10-1.hs" + void . insert $ SubmissionFile sub1 sub1fid1 False False -- datenbanksysteme - dbs <- insert Course + dbs <- insert' Course { courseName = "Datenbanksysteme" , courseDescription = Nothing , courseLinkExternal = Nothing @@ -313,7 +341,7 @@ fillDb = do , courseMaterialFree = True } insert_ $ CourseEdit gkleen now dbs - void . insert $ DegreeCourse dbs sdBsc sdInf - void . insert $ DegreeCourse dbs sdBsc sdMath - void . insert $ Lecturer gkleen dbs - void . insert $ Lecturer jost dbs + void . insert' $ DegreeCourse dbs sdBsc sdInf + void . insert' $ DegreeCourse dbs sdBsc sdMath + void . insert' $ Lecturer gkleen dbs + void . insert' $ Lecturer jost dbs diff --git a/ghci.sh b/ghci.sh index 5139c7c72..825a936f0 100755 --- a/ghci.sh +++ b/ghci.sh @@ -16,4 +16,4 @@ if [[ -d .stack-work-ghci ]]; then trap move-back EXIT fi -stack ghci --flag uniworx:dev --flag uniworx:library-only +stack ghci --flag uniworx:dev --flag uniworx:library-only ${@} diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1bd1ddd42..898b4385a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -16,7 +16,7 @@ WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year} SummerTermShort year@Integer: SoSe #{display year} WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100} PSLimitNonPositive: “pagesize” muss größer als null sein -Page n@Int64: #{display n} +Page num@Int64: #{display num} TermsHeading: Semesterübersicht TermCurrent: Aktuelles Semester @@ -91,6 +91,7 @@ SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. SheetUploadMode: Abgabe von Dateien +SheetSubmissionMode: Abgabe-Modus SheetExercise: Aufgabenstellung SheetHint: Hinweis SheetHintFrom: Hinweis ab @@ -111,6 +112,8 @@ SheetActiveTo: Abgabefrist SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren +SheetPseudonym: Persönliches Abgabe-Pseudonym +SheetGeneratePseudonym: Generieren SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen @@ -128,7 +131,7 @@ 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 g@Int: Mitabgebende(r) ##{display g} +SubmissionMember n@Int: Mitabgebende(r) ##{display n} SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien @@ -155,11 +158,15 @@ UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. +UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen. +UnauthorizedCorrectorSubmission: Korrektoren dürfen für dieses Übungsblatt keine Abgaben erstellen. OnlyUploadOneFile: Bitte nur eine Datei hochladen. DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung +UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. +UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} EMail: E-Mail @@ -193,8 +200,10 @@ LoginTitle: Authentifizierung ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum +SystemMessageHeading: Uni2Work Statusmeldung +SystemMessageListHeading: Uni2Work Statusmeldungen -NumCourses n@Int64: #{display n} Kurse +NumCourses num@Int64: #{display num} Kurse CloseAlert: Schliessen Name: Name @@ -245,10 +254,13 @@ RatingComment: Kommentar SubmissionUsers: Studenten Rating: Korrektur RatingPoints: Punkte +RatingDone: Bewertung fertiggestellt RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist +ColumnRatingPointsDone: Punktzahl/Abgeschlossen +Pseudonyms: Pseudonyme FileTitle: Dateiname FileModified: Letzte Änderung @@ -274,6 +286,7 @@ DateFormat: Datumsformat TimeFormat: Uhrzeitformat DownloadFiles: Dateien automatisch herunterladen DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). +NotificationSettings: Erwünschte Benachrichtigungen InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren @@ -305,7 +318,126 @@ UploadModeNone: Kein Upload UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken +SheetNoSubmission: Keine Abgabe +SheetCorrectorSubmissions: Abgaben durch Korrektoren +SheetUserSubmissions: Direkte Abgabe + SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. FieldPrimary: Hauptfach FieldSecondary: Nebenfach + +MailTestFormEmail: Email-Addresse +MailTestFormLanguages: Spracheinstellungen + +MailTestSubject: Uni2Work Test-Email +MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig. +MailTestDateTime: Test der Datumsformattierung: + +German: Deutsch +GermanGermany: Deutsch (Deutschland) + +MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert +MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert. + +MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben +MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. + +MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden +MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze. +MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfristt für #{sheetName} in #{csh} abgelaufen +MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet. +MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt. +MailEditNotifications: Benachrichtigungen ein-/ausschalten +MailSubjectSupport: Supportanfrage + +SheetTypeBonus: Bonus +SheetTypeNormal: Normal +SheetTypePass: Bestehen +SheetTypeNotGraded: Keine Wertung + +SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte +SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte +SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten +SheetTypeNotGraded': Nicht gewertet + +SheetTypeMaxPoints: Maximalpunktzahl +SheetTypePassingPoints: Notwendig zum Bestehen + +SheetGroupArbitrary: Arbiträre Gruppen +SheetGroupRegisteredGroups: Registrierte Gruppen +SheetGroupNoGroups: Keine Gruppenabgabe +SheetGroupMaxGroupsize: Maximale Gruppengröße + +SheetFiles: Übungsblatt-Dateien + +NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert +NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert +NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen +NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben +NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen +NotificationCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt + +CorrCreate: Abgaben erstellen +UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" +InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}" +UnknownPseudonym pseudonym@Text: Unbekanntes Pseudonym "#{pseudonym}" +CorrectionPseudonyms: Abgaben-Pseudonyme +CorrectionPseudonymsTip: Eine Abgabe pro Zeile, bei Gruppenabgaben mehrere Pseudonyme (komma-separiert) innerhalb einer Zeile +PseudonymSheet: Übungsblatt +CorrectionPseudonymSheet termDesc@Text csh@CourseShorthand shn@SheetName: #{termDesc} > #{csh} > #{shn} +SheetGroupTooLarge sheetGroupDesc@Text: Abgabegruppe zu groß: #{sheetGroupDesc} +SheetNoRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" sind nicht als Gruppe registriert +SheetAmbiguousRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" enthält Mitglieder aus verschiedenen registrierten Gruppen +SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt nicht vorgesehen (#{sheetGroupDesc}) +SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert: +SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: + +CorrGrade: Korrekturen eintragen + +UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! + +HelpAnswer: Antworten an +HelpUser: Meinen Benutzeraccount +HelpAnonymous: Keine Antwort (Anonym) +HelpEMail: E-Mail +HelpRequest: Supportanfrage / Verbesserungsvorschlag +HelpProblemPage: Problematische Seite +HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten. +HelpSent: Ihre Supportanfrage wurde weitergeleitet. + +SystemMessageFrom: Sichtbar ab +SystemMessageTo: Sichtbar bis +SystemMessageAuthenticatedOnly: Nur angemeldet +SystemMessageSeverity: Schwere +SystemMessageId: Id +SystemMessageSummaryContent: Zusammenfassung / Inhalt +SystemMessageSummary: Zusammenfassung +SystemMessageContent: Inhalt +SystemMessageLanguage: Sprache + +SystemMessageDelete: Löschen +SystemMessageActivate: Sichtbar schalten +SystemMessageDeactivate: Unsichtbar schalten +SystemMessageTimestamp: Zeitpunkt + +SystemMessagesDeleted: System-Nachrichten gelöscht: +SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt: +SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt: +SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt +SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId} +SystemMessageEdit: Statusmeldung anpassen +SystemMessageEditTranslations: Übersetzungen anpassen +SystemMessageAddTranslation: Übersetzung hinzufügen + +SystemMessageEditSuccess: Statusmeldung angepasst. +SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt. +SystemMessageEditTranslationSuccess: Übersetzung angepasst. +SystemMessageDeleteTranslationSuccess: Übersetzung entfernt. + +MessageError: Fehler +MessageWarning: Warnung +MessageInfo: Information +MessageSuccess: Erfolg + +InvalidLangFormat: Ungültiger Sprach-Code (RFC1766) \ No newline at end of file diff --git a/models b/models index 594b69fad..1398a65a5 100644 --- a/models +++ b/models @@ -11,6 +11,8 @@ User json dateFormat DateTimeFormat "default='%d.%m.%Y'" timeFormat DateTimeFormat "default='%R'" downloadFiles Bool default=false + mailLanguages MailLanguages "default='[]'" + notificationSettings NotificationSettings UniqueAuthentication ident UniqueEmail email deriving Show @@ -109,11 +111,18 @@ Sheet hintFrom UTCTime Maybe solutionFrom UTCTime Maybe uploadMode UploadMode + submissionMode SheetSubmissionMode default='UserSubmissions' CourseSheet course name SheetEdit user UserId time UTCTime sheet SheetId +SheetPseudonym + sheet SheetId + pseudonym Pseudonym + user UserId + UniqueSheetPseudonym sheet pseudonym + UniqueSheetPseudonymUser sheet user SheetCorrector user UserId sheet SheetId @@ -150,7 +159,7 @@ SubmissionFile isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile file submission isUpdate deriving Show -SubmissionUser +SubmissionUser -- Actual submission participant user UserId submission SubmissionId UniqueSubmissionUser user submission @@ -161,7 +170,7 @@ SubmissionGroupEdit user UserId time UTCTime submissionGroup SubmissionGroupId -SubmissionGroupUser +SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user @@ -221,3 +230,29 @@ Exam -- -- CONTINUE HERE: Include rating in this table or separately? -- UniqueExamUser user examId -- By default this file is used in Model.hs (which is imported by Foundation.hs) +QueuedJob + content Value + creationInstance InstanceId + creationTime UTCTime + lockInstance InstanceId Maybe + lockTime UTCTime Maybe + deriving Eq Read Show Generic Typeable +CronLastExec + job Value + time UTCTime + instance InstanceId + UniqueCronLastExec job +SystemMessage + from UTCTime Maybe + to UTCTime Maybe + authenticatedOnly Bool + severity MessageClass + defaultLanguage Lang + content Html + summary Html Maybe +SystemMessageTranslation + message SystemMessageId + language Lang + content Html + summary Html Maybe + UniqueSystemMessageTranslation message language \ No newline at end of file diff --git a/package.yaml b/package.yaml index 613489a82..4a48ee43d 100644 --- a/package.yaml +++ b/package.yaml @@ -77,6 +77,9 @@ dependencies: - parsec - uuid - exceptions +- stm +- stm-chans +- stm-conduit - lens - MonadRandom - email-validate @@ -90,8 +93,20 @@ dependencies: - connection - universe - universe-base +- random - random-shuffle - th-abstraction +- HaskellNet +- HaskellNet-SSL +- network +- resource-pool +- mime-mail +- hashable +- aeson-pretty +- resourcet +- postgresql-simple +- word24 +- mmorph # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index 6116665dc..991318c6a 100644 --- a/routes +++ b/routes @@ -37,6 +37,7 @@ /admin/user/#CryptoUUIDUser AdminUserR GET /admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST /info VersionR GET !free +/help HelpR GET POST !free /profile ProfileR GET POST !free !free /profile/data ProfileDataR GET POST !free !free @@ -72,7 +73,7 @@ /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only - /subs/new SubmissionNewR GET POST !timeANDregistered + /subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions /subs/own SubmissionOwnR GET !free -- just redirect /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: / SubShowR GET POST !ownerANDtime !ownerANDisRead @@ -80,11 +81,18 @@ /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner /correctors SCorrR GET POST + /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector -/corrections CorrectionsR GET POST !corrector !lecturer -/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer +/submissions CorrectionsR GET POST !corrector !lecturer +/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer +/submissions/create CorrectionsCreateR GET POST !corrector !lecturer +/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer + + +/msgs MessageListR GET POST +/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication !/#UUID CryptoUUIDDispatchR GET !free -- just redirect diff --git a/src/Application.hs b/src/Application.hs index 9c4cb5a54..9ffcf2106 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Application ( getApplicationDev, getAppDevSettings @@ -13,6 +14,7 @@ module Application , makeFoundation , makeLogWare -- * for DevelMain + , foundationStoreNum , getApplicationRepl , shutdownApp -- * for GHCI @@ -21,7 +23,7 @@ module Application , addPWEntry ) where -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) import Import @@ -38,12 +40,34 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Foreign.Store + +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID + +import System.Directory +import System.FilePath + +import Jobs + import qualified Data.Text.Encoding as Text import Yesod.Auth.Util.PasswordStore -import qualified Data.ByteString.Char8 as BS -import qualified Data.Yaml as Yaml +import qualified Data.ByteString.Lazy as LBS +import Network.HaskellNet.SSL hiding (Settings) +import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings) +import Data.Pool + +import Control.Monad.Trans.Resource + +import System.Log.FastLogger.Date +import qualified Yesod.Core.Types as Yesod (Logger(..)) + +import qualified Data.HashMap.Strict as HashMap + +import Control.Lens ((&)) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -58,6 +82,7 @@ import Handler.Sheet import Handler.Submission import Handler.Corrections import Handler.CryptoIDDispatch +import Handler.SystemMessage -- This line actually creates our YesodDispatch instance. It is the second half @@ -69,70 +94,140 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeFoundation :: AppSettings -> IO UniWorX +makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX makeFoundation appSettings@(AppSettings{..}) = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager - appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger - appStatic <- - (if appMutableStatic then staticDevel else static) - appStaticDir + appLogger <- liftIO $ do + tgetter <- newTimeCache "%Y-%m-%d %T %z" + loggerSet <- newStdoutLoggerSet defaultBufSize + return $ Yesod.Logger loggerSet tgetter + appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir appCryptoIDKey <- readKeyFile appCryptoIDKeyFile + appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile + + (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do + chan <- newBroadcastTMChan + recvChan <- dupTMChan chan + return (chan, recvChan) + + appLogSettings <- liftIO $ newTVarIO appInitialLogSettings -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool = UniWorX {..} + let mkFoundation appConnPool appSmtpPool = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html - tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" + tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") logFunc = messageLoggerSource tempFoundation appLogger - -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool + flip runLoggingT logFunc $ do + $logDebugS "InstanceID" $ UUID.toText appInstanceID + -- $logDebugS "Configuration" $ tshow appSettings + + smtpPool <- traverse createSmtpPool appSmtpConf + + -- Create the database connection pool + sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) + + -- Perform database migration using our application's logging settings. + migrateAll `runSqlPool` sqlPool - -- Perform database migration using our application's logging settings. - runLoggingT (runSqlPool migrateAll pool) logFunc + handleJobs recvChans $ mkFoundation sqlPool smtpPool - -- Return the foundation - return $ mkFoundation pool + -- Return the foundation + return $ mkFoundation sqlPool smtpPool + +readInstanceIDFile :: MonadIO m => FilePath -> m UUID +readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS + where + parseBS :: LBS.ByteString -> IO UUID + parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString + generateInstead :: IOException -> IO UUID + generateInstead e + | isDoesNotExistError e = do + createDirectoryIfMissing True $ takeDirectory idFile + instanceId <- UUID.nextRandom + LBS.writeFile idFile $ UUID.toByteString instanceId + return instanceId + | otherwise = throw e + +createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool +createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do + logFunc <- askLoggerIO + let + withLogging :: LoggingT IO a -> IO a + withLogging = flip runLoggingT logFunc + + mkConnection = withLogging $ do + $logInfoS "SMTP" "Opening new connection" + liftIO mkConnection' + mkConnection' + | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort + | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort + | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort + reapConnection conn = withLogging $ do + $logDebugS "SMTP" "Closing connection" + liftIO $ closeSMTP conn + applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection + applyAuth SmtpAuthConf{..} conn = withLogging $ do + $logDebugS "SMTP" "Doing authentication" + authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn + when (not authSuccess) $ do + fail "SMTP authentication failed" + return conn + liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. -makeApplication :: UniWorX -> IO Application -makeApplication foundation = do +makeApplication :: MonadIO m => UniWorX -> m Application +makeApplication foundation = liftIO $ do logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation return $ logWare $ defaultMiddlewaresNoLogging appPlain -makeLogWare :: UniWorX -> IO Middleware -makeLogWare foundation = - mkRequestLogger def - { outputFormat = - if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else Apache - (if appIpFromHeader $ appSettings foundation - then FromFallback - else FromSocket) - , destination = Logger $ loggerSet $ appLogger foundation - } +makeLogWare :: MonadIO m => UniWorX -> m Middleware +makeLogWare app = do + logWareMap <- liftIO $ newTVarIO HashMap.empty + let + mkLogWare ls@LogSettings{..} = do + logWare <- mkRequestLogger def + { outputFormat = bool + (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app) + (Detailed True) + logDetailed + , destination = Logger . loggerSet $ appLogger app + } + atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare + return logWare + + void. liftIO $ + mkLogWare =<< readTVarIO (appLogSettings app) + + return $ \wai req fin -> do + lookupRes <- atomically $ do + ls <- readTVar $ appLogSettings app + existing <- HashMap.lookup ls <$> readTVar logWareMap + return $ maybe (Left ls) Right existing + logWare <- either mkLogWare return lookupRes + logWare wai req fin -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings -warpSettings foundation = - setPort (appPort $ appSettings foundation) - $ setHost (appHost $ appSettings foundation) - $ setOnException (\_req e -> +warpSettings foundation = defaultSettings + & setPort (appPort $ appSettings foundation) + & setHost (appHost $ appSettings foundation) + & setOnException (\_req e -> when (defaultShouldDisplayException e) $ messageLoggerSource foundation (appLogger foundation) @@ -140,29 +235,30 @@ warpSettings foundation = "yesod" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) - defaultSettings -- | For yesod devel, return the Warp settings and WAI Application. -getApplicationDev :: IO (Settings, Application) +getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application) getApplicationDev = do settings <- getAppDevSettings foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation + wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation return (wsettings, app) -getAppDevSettings :: IO AppSettings -getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppDevSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv -- | main function for use by yesod devel develMain :: IO () -develMain = develMainHelper getApplicationDev +develMain = runResourceT $ + liftIO . develMainHelper . return =<< getApplicationDev -- | The @main@ function for an executable running this site. -appMain :: IO () -appMain = do +appMain :: MonadResourceBase m => m () +appMain = runResourceT $ do -- Get the settings from all relevant sources - settings <- loadYamlSettingsArgs + settings <- liftIO $ + loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime [configSettingsYmlValue] @@ -176,22 +272,31 @@ appMain = do app <- makeApplication foundation -- Run the application with Warp - runSettings (warpSettings foundation) app + liftIO $ runSettings (warpSettings foundation) app -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the app from GHCi) -------------------------------------------------------------- -getApplicationRepl :: IO (Int, UniWorX, Application) +foundationStoreNum :: Word32 +foundationStoreNum = 2 + +getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation + wsettings <- liftIO . getDevSettings $ warpSettings foundation app1 <- makeApplication foundation + + let foundationStore = Store foundationStoreNum + liftIO $ deleteStore foundationStore + liftIO $ writeStore foundationStore foundation + return (getPort wsettings, foundation, app1) -shutdownApp :: UniWorX -> IO () -shutdownApp _ = return () +shutdownApp :: MonadIO m => UniWorX -> m () +shutdownApp UniWorX{..} = do + liftIO . atomically $ mapM_ closeTMChan appJobCtl --------------------------------------------- @@ -200,7 +305,7 @@ shutdownApp _ = return () -- | Run a handler handler :: Handler a -> IO a -handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h +handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a @@ -209,7 +314,7 @@ db = handler . runDB addPWEntry :: User -> Text {-^ Password -} -> IO () -addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do +addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} diff --git a/src/Cron.hs b/src/Cron.hs new file mode 100644 index 000000000..2620aec12 --- /dev/null +++ b/src/Cron.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , PatternGuards + , ViewPatterns + , DeriveFunctor + , TemplateHaskell + , NamedFieldPuns + #-} + +module Cron + ( CronNextMatch(..) + , nextCronMatch + , module Cron.Types + ) where + +import ClassyPrelude +import Prelude (lcm) +import Cron.Types + +import Data.Time +import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid) +import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid) +import Data.Time.Zones + +import Numeric.Natural +import Data.Ratio ((%)) + +import qualified Data.Set as Set + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +import Utils.Lens.TH +import Control.Lens + + +data CronDate = CronDate + { cdYear, cdWeekOfYear, cdDayOfYear + , cdMonth, cdWeekOfMonth, cdDayOfMonth + , cdDayOfWeek + , cdHour, cdMinute, cdSecond :: Natural + } deriving (Eq, Show, Read) + +makeLenses_ ''CronDate + + +evalCronMatch :: CronMatch -> Natural -> Bool +evalCronMatch CronMatchAny _ = True +evalCronMatch CronMatchNone _ = False +evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set +evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0 +evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to +evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x +evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x + +toCronDate :: LocalTime -> CronDate +toCronDate LocalTime{..} = CronDate{..} + where + (fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth) + = toGregorian localDay + (_, fromIntegral -> cdDayOfYear) + = toOrdinalDate localDay + (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek) + = toWeekDate localDay + cdWeekOfMonth = go 1 localDay + where + go :: Natural -> Day -> Natural + go n day + | dow /= 4 = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday + | m == m' = go (succ n) day' + | otherwise = n + where + (y, w, dow) = toWeekDate day + day' + | w /= 0 = fromWeekDate y (pred w) dow + | otherwise = fromWeekDate (pred y) 53 dow + (_, m, _) = toGregorian day + (_, m', _) = toGregorian day' + TimeOfDay + { todHour = fromIntegral -> cdHour + , todMin = fromIntegral -> cdMinute + , todSec = round -> cdSecond + } = localTimeOfDay + +consistentCronDate :: CronDate -> Bool +consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do + gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth) + wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek) + guard $ gDay == wDay + oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear) + guard $ wDay == oDay + guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate")) + return True + + +data CronNextMatch a = MatchAsap | MatchAt a | MatchNone + deriving (Eq, Ord, Show, Read, Functor) + +instance Applicative CronNextMatch where + pure = MatchAt + _ <*> MatchNone = MatchNone + MatchNone <*> _ = MatchNone + _ <*> MatchAsap = MatchAsap + MatchAsap <*> _ = MatchAsap + MatchAt f <*> MatchAt x = MatchAt $ f x + +instance Alternative CronNextMatch where + empty = MatchNone + x <|> MatchNone = x + MatchNone <|> x = x + _ <|> MatchAsap = MatchAsap + MatchAsap <|> _ = MatchAsap + (MatchAt a) <|> (MatchAt _) = MatchAt a + + +listToMatch :: [a] -> CronNextMatch a +listToMatch [] = MatchNone +listToMatch (t:_) = MatchAt t + +genMatch :: Int -- ^ Period + -> Bool -- ^ Modular + -> Natural -- ^ Start value + -> CronMatch + -> [Natural] +genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..] +genMatch _ _ _ CronMatchNone = [] +genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set +genMatch p m st (CronMatchStep step) = do + start <- [st..st + step] + guard $ (start `mod` step) == 0 + take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..] +genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to] +genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = [] +genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = [] +genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other +genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other +genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2)) + = genMatch p m st . CronMatchStep $ lcm st1 st2 +genMatch p m st (CronMatchIntersect aGen bGen) + | [] <- as' = [] + | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen) + where + as' = genMatch p m st aGen + mergeAnd [] _ = [] + mergeAnd _ [] = [] + mergeAnd (a:as) (b:bs) + | a < b = mergeAnd as (b:bs) + | a == b = a : mergeAnd as bs + | a > b = mergeAnd (a:as) bs +genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other +genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other +genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny +genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny +genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen) + where + merge [] bs = bs + merge as [] = as + merge (a:as) (b:bs) + | a < b = a : merge as (b:bs) + | a == b = a : merge as bs + | a > b = b : merge (a:as) bs + +nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry + -> Maybe UTCTime -- ^ Time of last execution of the job + -> UTCTime -- ^ Current time, used only for `CronCalendar` + -> Cron + -> CronNextMatch UTCTime +nextCronMatch tz mPrev now c@Cron{..} = case notAfter of + MatchAsap -> MatchNone + MatchAt ts + | MatchAt ts' <- nextMatch + , ts' <= ts -> MatchAt ts' + | MatchAsap <- nextMatch + , now <= ts -> MatchAsap + | otherwise -> MatchNone + MatchNone -> nextMatch + where + nextMatch = nextCronMatch' tz mPrev now c + notAfter + | Right c' <- cronNotAfter + , Just ref <- notAfterRef + = execRef' ref False c' + | Left diff <- cronNotAfter + , Just ref <- notAfterRef + = MatchAt $ diff `addUTCTime` ref + | otherwise = MatchNone + notAfterRef + | Just prevT <- mPrev = Just prevT + | otherwise = case execRef' now False cronInitial of + MatchAt t -> Just t + MatchNone -> Nothing + + nextCronMatch' tz mPrev now c@Cron{..} + | isNothing mPrev + = execRef now False cronInitial + | Just prevT <- mPrev + = case cronRepeat of + CronRepeatOnChange + | not $ matchesCron tz Nothing prevT c + -> let + cutoffTime = addUTCTime cronRateLimit prevT + in case execRef now False cronInitial of + MatchAsap + | now < cutoffTime -> MatchAt cutoffTime + MatchAt ts + | ts < cutoffTime -> MatchAt cutoffTime + other -> other + CronRepeatScheduled cronNext + -> case cronNext of + CronAsap + | addUTCTime cronRateLimit prevT <= now + -> MatchAsap + | otherwise + -> MatchAt $ addUTCTime cronRateLimit prevT + cronNext + -> execRef (addUTCTime cronRateLimit prevT) True cronNext + _other -> MatchNone + + execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of + MatchAt t + | t <= ref -> MatchAsap + other -> other + + execRef' ref wasExecd cronAbsolute = case cronAbsolute of + CronAsap -> MatchAt ref + CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts } + | ref <= ts || not wasExecd -> MatchAt ts + | otherwise -> MatchNone + CronCalendar{..} -> listToMatch $ do + let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref + cronYear <- genMatch 400 False cdYear cronYear + cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear + cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear + cronMonth <- genMatch 12 True cdMonth cronMonth + cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth + cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth + cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek + cronHour <- genMatch 24 True cdHour cronHour + cronMinute <- genMatch 60 True cdMinute cronMinute + cronSecond <- genMatch 60 True cdSecond cronSecond + guard $ consistentCronDate CronDate{..} + localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) + let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) + return $ localTimeToUTCTZ tz LocalTime{..} + CronNotScheduled -> MatchNone + +matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry + -> Maybe UTCTime -- ^ Previous execution of the job + -> UTCTime -- ^ "Current" time + -> Cron + -> Bool +-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron` +-- specification @c@ should match @now@, under the assumption that the next +-- check will occur no earlier than @now + prec@. +matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of + MatchAsap -> True + MatchNone -> False + MatchAt ts -> ts <= now diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs new file mode 100644 index 000000000..fa95477f0 --- /dev/null +++ b/src/Cron/Types.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , DuplicateRecordFields + #-} + +module Cron.Types + ( Cron(..), Crontab + , CronMatch(..) + , CronAbsolute(..) + , CronRepeat(..) + ) where + +import ClassyPrelude + +import Utils.Lens.TH + +import Data.Time + +import Numeric.Natural + +import Data.HashMap.Strict (HashMap) + + +data CronMatch + = CronMatchAny + | CronMatchNone + | CronMatchSome (NonNull (Set Natural)) + | CronMatchStep Natural + | CronMatchContiguous Natural Natural + | CronMatchIntersect CronMatch CronMatch + | CronMatchUnion CronMatch CronMatch + deriving (Eq, Show, Read) + +data CronAbsolute + = CronAsap + | CronTimestamp + { cronTimestamp :: LocalTime + } + | CronCalendar + { cronYear, cronWeekOfYear, cronDayOfYear + , cronMonth, cronWeekOfMonth, cronDayOfMonth + , cronDayOfWeek + , cronHour, cronMinute, cronSecond :: CronMatch + } + | CronNotScheduled + deriving (Eq, Show, Read) + +makeLenses_ ''CronAbsolute + +data CronRepeat + = CronRepeatOnChange + | CronRepeatScheduled CronAbsolute + | CronRepeatNever + deriving (Eq, Show, Read) + +data Cron = Cron + { cronInitial :: CronAbsolute + , cronRepeat :: CronRepeat + , cronRateLimit :: NominalDiffTime + , cronNotAfter :: Either NominalDiffTime CronAbsolute + } + deriving (Eq, Show) + +makeLenses_ ''Cron + +type Crontab a = HashMap a Cron diff --git a/src/CryptoID.hs b/src/CryptoID.hs index e2f6361cb..58f68171e 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -38,6 +38,9 @@ import qualified Data.CaseInsensitive as CI decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId + , ''SheetId + , ''SystemMessageId + , ''SystemMessageTranslationId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Data/Universe/Instances/Reverse/Hashable.hs b/src/Data/Universe/Instances/Reverse/Hashable.hs new file mode 100644 index 000000000..e7459f613 --- /dev/null +++ b/src/Data/Universe/Instances/Reverse/Hashable.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Universe.Instances.Reverse.Hashable + ( + ) where + +import ClassyPrelude + +import Data.Universe + + +instance (Hashable a, Hashable b, Finite a) => Hashable (a -> b) where + hashWithSalt s f = s `hashWithSalt` [ (k, f k) | k <- universeF ] diff --git a/src/Data/Universe/Instances/Reverse/JSON.hs b/src/Data/Universe/Instances/Reverse/JSON.hs new file mode 100644 index 000000000..60b7ba6ae --- /dev/null +++ b/src/Data/Universe/Instances/Reverse/JSON.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Universe.Instances.Reverse.JSON + ( + ) where + +import ClassyPrelude + +import Data.Aeson +import Data.Aeson.Types (Parser) + +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict ((!)) + +import Data.Universe + + +instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) where + toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF] + +instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where + parseJSON val = do + vMap <- parseJSON val :: Parser (HashMap a b) + unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $ + fail "Not all required keys found" + return $ (vMap !) diff --git a/src/Foundation.hs b/src/Foundation.hs index 105c859ab..fe478f1ca 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -20,12 +20,12 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) --- Used only when in "auth-dummy-login" setting is enabled. import Yesod.Auth.Message import Yesod.Auth.Dummy import Auth.LDAP import Auth.PWHash import Auth.Dummy +import Jobs.Types import qualified Network.Wai as W (requestMethod, pathInfo) @@ -56,9 +56,11 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map +import Data.List (findIndex) import Data.Monoid (Any(..)) +import Data.Pool import Data.Conduit (($$)) import Data.Conduit.List (sourceList) @@ -67,7 +69,7 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.Reader (runReader) +import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Catch (handleAll) @@ -81,13 +83,19 @@ import Control.Lens import Utils import Utils.Form import Utils.Lens +import Utils.SystemMessage -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Success) import Data.Aeson.TH import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) +import Yesod.Form.I18n.German +import qualified Yesod.Auth.Message as Auth + +import qualified Data.Conduit.List as C + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -112,11 +120,17 @@ data UniWorX = UniWorX { appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appSmtpPool :: Maybe SMTPPool , appHttpManager :: Manager , appLogger :: Logger + , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey + , appInstanceID :: InstanceId + , appJobCtl :: [TMChan JobCtl] } +type SMTPPool = Pool SMTPConnection + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers @@ -135,6 +149,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes") type DB a = YesodDB UniWorX a type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils +type MailM a = MailT (HandlerT UniWorX IO) a -- Pattern Synonyms for convenience pattern CSheetR tid ssh csh shn ptn @@ -146,9 +161,10 @@ pattern CSubmissionR tid ssh csh shn cid ptn -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text - , menuItemIcon :: Maybe Text + , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) + , menuItemModal :: Bool } menuItemAccessCallback :: MenuItem -> Handler Bool @@ -173,7 +189,7 @@ mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage UniWorX FormMessage where - renderMessage _ _ = defaultFormMessage + renderMessage _ _ = germanFormMessage -- TODO instance RenderMessage UniWorX TermIdentifier where renderMessage foundation ls TermIdentifier{..} = case season of @@ -182,10 +198,9 @@ instance RenderMessage UniWorX TermIdentifier where where renderMessage' = renderMessage foundation ls instance RenderMessage UniWorX StudyFieldType where - renderMessage foundation ls = \case - FieldPrimary -> renderMessage' MsgFieldPrimary - FieldSecondary -> renderMessage' MsgFieldSecondary - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + FieldPrimary -> MsgFieldPrimary + FieldSecondary -> MsgFieldSecondary newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving (Eq, Ord, Read, Show) @@ -200,32 +215,60 @@ instance RenderMessage UniWorX String where renderMessage f ls str = renderMessage f ls $ Text.pack str instance RenderMessage UniWorX SheetFileType where - renderMessage foundation ls = \case - SheetExercise -> renderMessage' MsgSheetExercise - SheetHint -> renderMessage' MsgSheetHint - SheetSolution -> renderMessage' MsgSheetSolution - SheetMarking -> renderMessage' MsgSheetMarking - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + SheetExercise -> MsgSheetExercise + SheetHint -> MsgSheetHint + SheetSolution -> MsgSheetSolution + SheetMarking -> MsgSheetMarking instance RenderMessage UniWorX CorrectorState where - renderMessage foundation ls = \case - CorrectorNormal -> renderMessage' MsgCorrectorNormal - CorrectorMissing -> renderMessage' MsgCorrectorMissing - CorrectorExcused -> renderMessage' MsgCorrectorExcused - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + CorrectorNormal -> MsgCorrectorNormal + CorrectorMissing -> MsgCorrectorMissing + CorrectorExcused -> MsgCorrectorExcused instance RenderMessage UniWorX Load where - renderMessage foundation ls = \case - (Load {byTutorial=Nothing , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p - (Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p - (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p - where renderMessage' = renderMessage foundation ls + renderMessage foundation ls = renderMessage foundation ls . \case + (Load {byTutorial=Nothing , byProportion=p}) -> MsgCorByProportionOnly p + (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p + (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p +instance RenderMessage UniWorX SheetType where + renderMessage foundation ls = renderMessage foundation ls . \case + Bonus{..} -> MsgSheetTypeBonus' maxPoints + Normal{..} -> MsgSheetTypeNormal' maxPoints + Pass{..} -> MsgSheetTypePass' maxPoints passingPoints + NotGraded{} -> MsgSheetTypeNotGraded' + +newtype MsgLanguage = MsgLanguage Lang + deriving (Eq, Ord, Show, Read) +instance RenderMessage UniWorX MsgLanguage where + renderMessage foundation ls (MsgLanguage lang) + | lang == "de-DE" = mr MsgGermanGermany + | "de" `isPrefixOf` lang = mr MsgGerman + where + mr = renderMessage foundation ls + +instance RenderMessage UniWorX NotificationTrigger where + renderMessage foundation ls = renderMessage foundation ls . \case + NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded + NTSubmissionRated -> MsgNotificationTriggerSubmissionRated + NTSheetActive -> MsgNotificationTriggerSheetActive + NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive + NTSheetInactive -> MsgNotificationTriggerSheetInactive + NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) +instance RenderMessage UniWorX MessageClass where + renderMessage f ls = renderMessage f ls . \case + Error -> MsgMessageError + Warning -> MsgMessageWarning + Info -> MsgMessageInfo + Success -> MsgMessageSuccess + data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -242,6 +285,23 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) appTZ :: TZ appTZ = $(includeSystemTZ "Europe/Berlin") +appLanguages :: NonEmpty Lang +appLanguages = "de-DE" :| [] + +appLanguagesOpts :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) => m (OptionList Lang) +-- ^ Authoritive list of supported Languages +appLanguagesOpts = do + mr <- getsYesod renderMessage + let mkOption l = Option + { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l) + , optionInternalValue = l + , optionExternalValue = l + } + langOptions = map mkOption $ toList appLanguages + return $ mkOptionList langOptions + -- Access Control data AccessPredicate @@ -389,6 +449,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req && NTop courseRegisterTo >= cTime return Authorized + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do + smId <- decrypt cID + SystemMessage{..} <- MaybeT $ get smId + cTime <- (NTop . Just) <$> liftIO getCurrentTime + guard $ NTop systemMessageFrom <= cTime + && NTop systemMessageTo >= cTime + return Authorized + r -> $unsupportedAuthPredicate "time" r ) ,("registered", APDB $ \route _ -> case route of @@ -436,6 +504,31 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized r -> $unsupportedAuthPredicate "rated" r ) + ,("user-submissions", APDB $ \route _ -> case route of + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn + guard $ sheetSubmissionMode == UserSubmissions + return Authorized + r -> $unsupportedAuthPredicate "user-submissions" r + ) + ,("corrector-submissions", APDB $ \route _ -> case route of + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn + guard $ sheetSubmissionMode == CorrectorSubmissions + return Authorized + r -> $unsupportedAuthPredicate "corrector-submissions" r + ) + ,("authentication", APDB $ \route _ -> case route of + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do + smId <- decrypt cID + SystemMessage{..} <- MaybeT $ get smId + isAuthenticated <- isJust <$> liftHandlerT maybeAuthId + guard $ not systemMessageAuthenticatedOnly || isAuthenticated + return Authorized + r -> $unsupportedAuthPredicate "authentication" r + ) ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)) ] @@ -454,14 +547,14 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK attrsAND = map splitAND $ Set.toList $ routeAttrs r splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" -evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r w = case route2ap r of +evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer (APHandler p) -> lift $ p r w (APDB p) -> p r w -evalAccess :: Route UniWorX -> Bool -> Handler AuthResult -evalAccess r w = case route2ap r of +evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess r w = liftHandlerT $ case route2ap r of (APPure p) -> runReader (p r w) <$> getMsgRenderer (APHandler p) -> p r w (APDB p) -> runDB $ p r w @@ -537,6 +630,8 @@ instance Yesod UniWorX where defaultLayout widget = do master <- getYesod let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master + + applySystemMessages mmsgs <- getMessages mcurrentRoute <- getCurrentRoute @@ -549,7 +644,7 @@ instance Yesod UniWorX where let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute - menuTypes <- filterM (menuItemAccessCallback . menuItem) menu + menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu isAuth <- isJust <$> maybeAuthId @@ -572,7 +667,7 @@ instance Yesod UniWorX where let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents - navItems = map snd3 favourites ++ map (menuItemRoute . menuItem) menuTypes + navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs in \r -> Just r == highR favouriteTerms :: [TermIdentifier] @@ -604,7 +699,7 @@ instance Yesod UniWorX where isPageActionPrime (PageActionSecondary _) = True isPageActionPrime _ = False hasPageActions :: Bool - hasPageActions = any isPageActionPrime menuTypes + hasPageActions = any (isPageActionPrime . fst) menuTypes pc <- widgetToPageContent $ do addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" @@ -665,11 +760,37 @@ instance Yesod UniWorX where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app) + shouldLog _ _ _ = error "Must use shouldLogIO" + shouldLogIO app _source level = do + LogSettings{..} <- readTVarIO $ appLogSettings app + return $ logAll || level >= logMinimumLevel makeLogger = return . appLogger +applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () +applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage + where + applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do + cID <- encrypt smId + let sessionKey = "sm-" <> tshow (ciphertext cID) + assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())) + setSessionJson sessionKey () + (SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId + let + (summary, content) = case smTrans of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + case summary of + Just s -> do + html <- withUrlRenderer [hamlet| + + #{s} + |] + addMessage systemMessageSeverity html + Nothing -> addMessage systemMessageSeverity content + -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) @@ -714,6 +835,12 @@ instance YesodBreadcrumbs UniWorX where -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) + breadcrumb (MessageR _) = do + mayList <- (== Authorized) <$> evalAccess MessageListR False + return $ if + | mayList -> ("Statusmeldung", Just MessageListR) + | otherwise -> ("Statusmeldung", Just HomeR) + breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR) breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] @@ -737,54 +864,70 @@ defaultLinks = -- Define the menu items of the header. { menuItemLabel = "Home" , menuItemIcon = Just "home" , menuItemRoute = HomeR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Impressum" , menuItemIcon = Just "book" , menuItemRoute = VersionR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem - { menuItemLabel = "Profil" + { menuItemLabel = "Hilfe" + , menuItemIcon = Just "question" + , menuItemRoute = HelpR + , menuItemModal = True -- TODO: Does not work yet, issue #212 + , menuItemAccessCallback' = return True + } + , NavbarRight $ MenuItem + { menuItemLabel = "Einstellungen" , menuItemIcon = Just "cogs" , menuItemRoute = ProfileR + , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemIcon = Just "sign-in-alt" , menuItemRoute = AuthR LoginR + , menuItemModal = True -- TODO: Does not work yet, issue #212 , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemIcon = Just "sign-out-alt" , menuItemRoute = AuthR LogoutR + , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem { menuItemLabel = "Kurse" , menuItemIcon = Just "calendar-alt" , menuItemRoute = CourseListR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Semester" , menuItemIcon = Just "graduation-cap" , menuItemRoute = TermShowR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Korrekturen" , menuItemIcon = Just "check" , menuItemRoute = CorrectionsR + , menuItemModal = False , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "users" , menuItemRoute = UsersR + , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } ] @@ -810,14 +953,23 @@ pageActions (HomeR) = { menuItemLabel = "AdminDemo" , menuItemIcon = Just "screwdriver" , menuItemRoute = AdminTestR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "System-Nachrichten" + , menuItemIcon = Nothing + , menuItemRoute = MessageListR + , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (ProfileR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Gespeicherte Daten anzeigen" + { menuItemLabel = "Gespeicherte Daten" , menuItemIcon = Just "book" , menuItemRoute = ProfileDataR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -826,6 +978,7 @@ pageActions TermShowR = { menuItemLabel = "Neues Semester anlegen" , menuItemIcon = Nothing , menuItemRoute = TermEditR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -834,12 +987,14 @@ pageActions (TermCourseListR tid) = { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Semster editieren" , menuItemIcon = Nothing , menuItemRoute = TermEditExistR tid + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -848,6 +1003,7 @@ pageActions (CourseListR) = { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -856,6 +1012,7 @@ pageActions (CourseR tid ssh csh CShowR) = { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetListR + , menuItemModal = False , menuItemAccessCallback' = do --TODO always show for lecturer let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False) muid <- maybeAuthId @@ -872,24 +1029,28 @@ pageActions (CourseR tid ssh csh CShowR) = { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh CCorrectionsR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Kurs editieren" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh CEditR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Neuen Kurs klonen" , menuItemIcon = Nothing , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh) + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -898,6 +1059,7 @@ pageActions (CourseR tid ssh csh SheetListR) = { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid ssh csh SheetNewR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -906,6 +1068,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR + , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -916,6 +1079,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = { menuItemLabel = "Abgabe ansehen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR + , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -926,18 +1090,21 @@ pageActions (CSheetR tid ssh csh shn SShowR) = { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SCorrR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SSubsR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Blatt Editieren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SEditR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -946,6 +1113,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SCorrR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -954,6 +1122,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = { menuItemLabel = "Korrektur" , menuItemIcon = Nothing , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -962,12 +1131,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = { menuItemLabel = "Abgaben" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SSubsR + , menuItemModal = False , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Edit " <> (CI.original shn) , menuItemIcon = Nothing , menuItemRoute = CSheetR tid ssh csh shn SEditR + , menuItemModal = False , menuItemAccessCallback' = return True } ] @@ -976,8 +1147,51 @@ pageActions (CorrectionsR) = { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing , menuItemRoute = CorrectionsUploadR + , menuItemModal = True , menuItemAccessCallback' = return True } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben erstellen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsCreateR + , menuItemModal = True + , menuItemAccessCallback' = runDB $ do + uid <- liftHandlerT requireAuthId + [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + return E.countRows + return $ (count :: Int) /= 0 + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Korrekturen eintragen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsGradeR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CorrectionsGradeR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Korrekturen hochladen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsUploadR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben erstellen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsCreateR + , menuItemModal = True + , menuItemAccessCallback' = runDB $ do + uid <- liftHandlerT requireAuthId + [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + return E.countRows + return $ (count :: Int) /= 0 + } ] pageActions _ = [] @@ -998,6 +1212,8 @@ pageHeading (AdminUserR _) = Just $ [whamlet|User Display for Admin|] pageHeading (VersionR) = Just $ i18nHeading MsgImpressumHeading +pageHeading (HelpR) + = Just $ i18nHeading MsgHelpRequest pageHeading ProfileR = Just $ i18nHeading MsgProfileHeading @@ -1069,6 +1285,14 @@ pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload +pageHeading CorrectionsCreateR + = Just $ i18nHeading MsgCorrCreate +pageHeading CorrectionsGradeR + = Just $ i18nHeading MsgCorrGrade +pageHeading (MessageR _) + = Just $ i18nHeading MsgSystemMessageHeading +pageHeading MessageListR + = Just $ i18nHeading MsgSystemMessageListHeading -- TODO: add headings for more single course- and single term-pages pageHeading _ @@ -1223,12 +1447,14 @@ instance YesodAuth UniWorX where let newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles + { userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userNotificationSettings = def + , userMailLanguages = def , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer @@ -1271,6 +1497,8 @@ instance YesodAuth UniWorX where authHttpManager = getHttpManager + renderAuthMessage _ _ = Auth.germanMessage -- TODO + instance YesodAuthPersist UniWorX -- Useful when writing code that is re-usable outside of the Handler context. @@ -1283,6 +1511,25 @@ unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger +instance YesodMail UniWorX where + defaultFromAddress = getsYesod $ appMailFrom . appSettings + mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings + mailVerp = getsYesod $ appMailVerp . appSettings + mailDateTZ = return appTZ + mailSmtp act = do + pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool + withResource pool act + mailT ctx mail = defMailT ctx $ do + setMailObjectId + setDateCurrent + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + + ret <- mail + + setMailSmtpData + return ret + + instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where type MonadCryptoKey m = CryptoIDKey cryptoIDKey f = getsYesod appCryptoIDKey >>= f diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 156961629..1b5c3ae9d 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -7,11 +7,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} module Handler.Admin where import Import import Handler.Utils +import Jobs -- import Data.Time -- import qualified Data.Text as T @@ -20,6 +22,8 @@ import Handler.Utils import Web.PathPieces (showToPathPiece, readFromPathPiece) +import Database.Persist.Sql (fromSqlKey) + -- import Colonnade hiding (fromMaybe) -- import Yesod.Colonnade @@ -41,22 +45,54 @@ instance Button UniWorX CreateButton where cssClass CreateInf = BCPrimary -- END Button needed here +emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) +emailTestForm = (,) + <$> areq emailField (fslI MsgMailTestFormEmail) Nothing + <*> ( MailContext + <$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing) + <*> (toMailDateTimeFormat + <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing + <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing + <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing + ) + ) + <* submitButton + where + toMailDateTimeFormat dt d t = \case + SelFormatDateTime -> dt + SelFormatDate -> d + SelFormatTime -> t -getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! -getAdminTestR = do - (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton) - defaultLayout $ do - -- setTitle "Uni2work Admin Testpage" - $(widgetFile "adminTest") -postAdminTestR :: Handler Html +getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! +getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult,_), _) <- runFormPost $ buttonForm + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" + FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" - getAdminTestR + + ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm + case emailResult of + (FormSuccess (email, ls)) -> do + jId <- runDB $ do + jId <- queueJob $ JobSendTestEmail email ls + addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] + return jId + writeJobCtl $ JobCtlPerform jId + FormMissing -> return () + (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml + + let emailWidget' = [whamlet| +
+ ^{emailWidget} + |] + + defaultLayout $ do + -- setTitle "Uni2work Admin Testpage" + $(widgetFile "adminTest") getAdminUserR :: CryptoUUIDUser -> Handler Html diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 94aab5738..9814f6d75 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} {-# LANGUAGE TemplateHaskell #-} @@ -21,11 +20,14 @@ module Handler.Corrections where import Import -- import System.FilePath (takeFileName) +import Jobs import Handler.Utils import Handler.Utils.Submission import Handler.Utils.Table.Cells -- import Handler.Utils.Zip +import Utils.Lens + import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) @@ -33,6 +35,8 @@ import qualified Data.Map as Map import qualified Data.Text as Text +import Data.Semigroup (Sum(..)) + -- import Data.Time -- import qualified Data.Text as T -- import Data.Function ((&)) @@ -46,7 +50,6 @@ import Colonnade hiding (fromMaybe, singleton, bool) import qualified Database.Esqueleto as E -- import qualified Database.Esqueleto.Internal.Sql as E -import Control.Lens -- import Control.Monad.Writer (MonadWriter(..), execWriterT) -- import Network.Mime @@ -60,6 +63,20 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import Control.Monad.Trans.RWS (RWST) + +import Control.Monad.Trans.State (State, StateT(..), runState) +import qualified Control.Monad.State.Class as State + +import Data.Foldable (foldrM) +import Data.Traversable (for) + type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) => @@ -75,8 +92,11 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid sheetIs :: Key Sheet -> CorrectionsWhere sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid +submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere +submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User) + +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) @@ -128,13 +148,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp tid = course ^. _3 ssh = course ^. _4 link cid = CourseR tid ssh csh $ CUserR cid - cell = listCell (Map.toList users) $ \(userId, User{..}) -> do - anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname) + cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> + anchorCellM (link <$> encrypt userId) $ case mPseudo of + Nothing -> nameWidget userDisplayName userSurname + Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|] in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let - cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) + cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) @@ -156,13 +178,36 @@ colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> maybe mempty timeCell submissionRatingTime +colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let + lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo -> + cell [whamlet|#{review pseudonymText pseudo}|] + in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + +colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b)))) +colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done)) + +colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b)))) +colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of + NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) + _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints) + ) + +colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text)))) +colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) -makeCorrectionsTable whereClause colChoices psValidator = do + => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy @@ -176,57 +221,64 @@ makeCorrectionsTable whereClause colChoices psValidator = do ) return (submission, sheet, crse, corrector) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData - dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do - submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do + submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do + E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) + E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId E.orderBy [E.asc $ user E.^. UserId] - return user + return (user, pseudonym E.?. SheetPseudonymPseudonym) let - submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) + submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors + dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) dbTable psValidator $ DBTable { dbtSQLQuery - , dbtColonnade = colChoices + , dbtColonnade , dbtProj - , dbtSorting = [ ( "term" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm - ) - , ( "course" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand - ) - , ( "sheet" - , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName - ) - , ( "corrector" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname - ) - , ( "rating" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints - ) - ] - , dbtFilter = [ ( "term" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - , ( "course" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if - | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) - ) - , ( "sheet" - , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if - | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) - ) - , ( "corrector" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if - | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) - E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) - ) - ] + , dbtSorting = Map.fromList + [ ( "term" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm + ) + , ( "course" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand + ) + , ( "sheet" + , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName + ) + , ( "corrector" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname + ) + , ( "rating" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints + ) + , ( "ratingtime" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime + ) + ] + , dbtFilter = Map.fromList + [ ( "term" + , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if + | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) + ) + , ( "course" + , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if + | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) + ) + , ( "sheet" + , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if + | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) + ) + , ( "corrector" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if + | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) + E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) + ) + ] , dbtStyle = def , dbtIdent = "corrections" :: Text } @@ -248,12 +300,12 @@ data ActionCorrectionsData = CorrDownloadData | CorrSetCorrectorData (Maybe UserId) | CorrAutoSetCorrectorData SheetId -correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent +correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do - tableForm <- makeCorrectionsTable whereClause displayColumns psValidator + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf - (actionRes, action) <- multiAction actions + (actionRes, action) <- multiAction actions Nothing return ((,) <$> actionRes <*> selectionRes, table <> action) Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler @@ -323,16 +375,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = $(widgetFile "corrections") -type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) +type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) downloadAction :: ActionCorrections' downloadAction = ( CorrDownload - , return (pure CorrDownloadData, Nothing) + , pure CorrDownloadData ) assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector - , over (mapped._2) Just $ do + , wFormToAForm $ do correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet @@ -346,14 +398,13 @@ assignAction selId = ( CorrSetCorrector correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey - ($ mempty) . renderAForm FormStandard . wFormToAForm $ do - cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing - fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId + cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing + fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) autoAssignAction :: SheetId -> ActionCorrections' autoAssignAction shid = ( CorrAutoSetCorrector - , return (pure $ CorrAutoSetCorrectorData shid, Nothing) + , pure $ CorrAutoSetCorrectorData shid ) getCorrectionsR, postCorrectionsR :: Handler TypedContent @@ -367,6 +418,7 @@ postCorrectionsR = do , colTerm , colCourse , colSheet + , colPseudonyms , colSubmissionLink , colAssigned , colRating @@ -449,9 +501,13 @@ postCorrectionR tid ssh csh shn cid = do case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) + pointsForm = case sheetType of + NotGraded -> pure Nothing + _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints) - ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) - <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) + ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) + <$> 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)) <* submitButton @@ -462,12 +518,12 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (ratingPoints, ratingComment) -> do - runDB $ do + FormSuccess (rated, ratingPoints, ratingComment) -> do + runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - let rated = isJust $ void ratingPoints <|> void ratingComment + Submission{submissionRatingTime} <- getJust sub update sub [ SubmissionRatingBy =. (uid <$ guard rated) -- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload @@ -478,6 +534,11 @@ postCorrectionR tid ssh csh shn cid = do ] addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated + + when (rated && isNothing submissionRatingTime) $ do + $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR case uploadResult of @@ -486,7 +547,7 @@ postCorrectionR tid ssh csh shn cid = do FormSuccess fileSource -> do uid <- requireAuthId - runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -521,7 +582,7 @@ postCorrectionsUploadR = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId - subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True + subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True if | null subs -> addMessageI Warning MsgNoCorrectionsUploaded | otherwise -> do @@ -532,3 +593,190 @@ postCorrectionsUploadR = do defaultLayout $ do $(widgetFile "corrections-upload") + +getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html +getCorrectionsCreateR = postCorrectionsCreateR +postCorrectionsCreateR = do + uid <- requireAuthId + let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid + E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] + return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName) + mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) + mkOptList opts = do + opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts + MsgRenderer mr <- getMsgRenderer + return . mkOptionList $ do + (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts' + let tid' = mr $ ShortTermIdentifier (unTermKey tid) + return Option + { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn + , optionInternalValue = sid + , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet) + } + ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) + <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing + <*> areq (checkMMap textToList textFromList textareaField) (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing + <* submitButton + + case pseudonymRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess (sid, pss) -> do + now <- liftIO getCurrentTime + runDB $ do + Sheet{..} <- get404 sid + (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) + forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText + now <- liftIO getCurrentTime + let + sps' :: [[SheetPseudonym]] + duplicate :: Set Pseudonym + ( sps' + , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate + ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do + known <- State.gets $ Map.member sheetPseudonymPseudonym + State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) + return $ bool (p :) id known ps + submission = Submission + { submissionSheet = sid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Just uid + , submissionRatingAssigned = Just now + , submissionRatingTime = Nothing + } + when (not $ null duplicate) + $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") + existingSubUsers <- E.select . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') + return submissionUser + when (not $ null existingSubUsers) $ do + (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers + $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") + let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' + forM_ sps'' $ \spGroup + -> let + sheetGroupDesc = Text.intercalate ", " $ map (review pseudonymText . sheetPseudonymPseudonym) spGroup + in case sheetGrouping of + Arbitrary maxSize + | genericLength sps > maxSize + -> addMessageI Error $ MsgSheetGroupTooLarge sheetGroupDesc + | otherwise + -> do + subId <- insert submission + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + RegisteredGroups -> do + groups <- E.select . E.from $ \submissionGroup -> do + E.where_ . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) + return $ submissionGroup E.^. SubmissionGroupId + case (groups :: [E.Value SubmissionGroupId]) of + [x] -> do + subId <- insert submission + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + [] -> do + subId <- insert submission + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc + _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc + NoGroups + | [SheetPseudonym{sheetPseudonymUser}] <- spGroup + -> do + subId <- insert submission + void . insert $ SubmissionEdit uid now subId + insert_ SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + | otherwise -> do + subId <- insert submission + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + redirect CorrectionsGradeR + + + defaultLayout $ do + $(widgetFile "corrections-create") + where + partition :: [[Either a b]] -> ([[b]], [a]) + partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) + + textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]]) + textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws) + = let + invalid :: [Text] + valid :: [[Pseudonym]] + (valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws + in case invalid of + (i:_) -> return . Left $ MsgInvalidPseudonym i + [] -> return $ Right valid + textFromList :: [[Pseudonym]] -> Textarea + textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText)) + +getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html +getCorrectionsGradeR = postCorrectionsGradeR +postCorrectionsGradeR = do + uid <- requireAuthId + let whereClause = ratedBy uid + displayColumns = mconcat -- should match getSSubsR for consistent UX + [ dbRow + , colTerm + , colCourse + , colSheet + , colPseudonyms + , colSubmissionLink + , colRated + , colRatedField + , colPointsField + , colCommentField + ] -- Continue here + psValidator = def + & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) + unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) + + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do + cID <- encrypt subId + void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True + return i + (((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm + + case tableRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess resMap -> do + now <- liftIO getCurrentTime + subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do + s@Submission{..} <- get404 subId + if + | submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s + -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints + , SubmissionRatingComment =. mComment + , SubmissionRatingBy =. Just uid + , SubmissionRatingTime =. now <$ guard rated + ] + | otherwise -> return $ Nothing + subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] + unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet") + + defaultLayout $ do + $(widgetFile "corrections-grade") diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 154c75d10..044f9b391 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -15,7 +15,7 @@ module Handler.Course where -import Import +import Import hiding (catMaybes) import Control.Lens import Utils.Lens @@ -33,6 +33,9 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.CaseInsensitive as CI + + import Colonnade hiding (fromMaybe,bool) -- import Yesod.Colonnade @@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do (_other) -> return () -- TODO check this! redirect $ CourseR tid ssh csh CShowR + +getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html +getCourseNewTemplateR mbTid mbSsh mbCsh = + redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid + , ("ssh",).CI.original.unSchoolKey <$> mbSsh + , ("csh",).CI.original <$> mbCsh + ]) + getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId @@ -325,59 +336,55 @@ getCourseNewR = do <*> iopt ciField "ssh" <*> iopt ciField "csh" let noTemplateAction = courseEditHandler True Nothing - case params of + case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more! FormMissing -> noTemplateAction - FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) - >> noTemplateAction - FormSuccess (mbTid,mbSsh,mbCsh) -> - getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh - -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh mbCsh = do - uid <- requireAuthId - oldCourses <- runDB $ do - E.select $ E.from $ \course -> do - whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid - whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh - whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh - let lecturersCourse = - E.exists $ E.from $ \lecturer -> do - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - let lecturersSchool = - E.exists $ E.from $ \user -> do - E.where_ $ user E.^. UserLecturerUser E.==. E.val uid - E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool - let courseCreated c = - E.sub_select . E.from $ \edit -> do -- oldest edit must be creation - E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId - return $ E.min_ $ edit E.^. CourseEditTime - E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer - , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer - , E.desc $ courseCreated course] -- most recent created course - E.limit 1 - return course - template <- case listToMaybe oldCourses of - (Just oldTemplate) -> - let newTemplate = (courseToForm oldTemplate) in - return $ Just $ newTemplate - { cfCourseId = Nothing - , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness - , cfRegFrom = Nothing - , cfRegTo = Nothing - , cfDeRegUntil = Nothing - } - Nothing -> do - (tidOk,sshOk,cshOk) <- runDB $ (,,) - <$> ifMaybeM mbTid True existsKey - <*> ifMaybeM mbSsh True existsKey - <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) - unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise - unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise - unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh - when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse - return Nothing - courseEditHandler True template + FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >> + noTemplateAction + FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do + uid <- requireAuthId + oldCourses <- runDB $ do + E.select $ E.from $ \course -> do + whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid + whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh + whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh + let lecturersCourse = + E.exists $ E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + let lecturersSchool = + E.exists $ E.from $ \user -> do + E.where_ $ user E.^. UserLecturerUser E.==. E.val uid + E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool + let courseCreated c = + E.sub_select . E.from $ \edit -> do -- oldest edit must be creation + E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId + return $ E.min_ $ edit E.^. CourseEditTime + E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer + , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer + , E.desc $ courseCreated course] -- most recent created course + E.limit 1 + return course + template <- case listToMaybe oldCourses of + (Just oldTemplate) -> + let newTemplate = (courseToForm oldTemplate) in + return $ Just $ newTemplate + { cfCourseId = Nothing + , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness + , cfRegFrom = Nothing + , cfRegTo = Nothing + , cfDeRegUntil = Nothing + } + Nothing -> do + (tidOk,sshOk,cshOk) <- runDB $ (,,) + <$> ifMaybeM mbTid True existsKey + <*> ifMaybeM mbSsh True existsKey + <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) + unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise + unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise + unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh + when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse + return Nothing + courseEditHandler True template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course. diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 73aa370d2..c0660967a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -2,6 +2,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear @@ -16,7 +18,14 @@ import Handler.Utils import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8') import Data.Time hiding (formatTime) +import Data.Universe +import Data.Universe.Helpers + +import Network.Wai (requestHeaderReferer) + -- import qualified Data.Text as T -- import Yesod.Form.Bootstrap3 @@ -27,6 +36,8 @@ import Data.Time hiding (formatTime) -- import Yesod.Colonnade import qualified Database.Esqueleto as E +import Jobs + -- import Text.Shakespeare.Text import Development.GitRev @@ -106,10 +117,10 @@ homeAnonymous = do , dbtStyle = def , dbtIdent = "upcomingdeadlines" :: Text } - let features = $(widgetFile "featureList") - addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" + -- let features = $(widgetFile "featureList") + -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" defaultLayout $ do - $(widgetFile "dsgvDisclaimer") + -- $(widgetFile "dsgvDisclaimer") $(widgetFile "home") homeUser :: Key User -> Handler Html @@ -117,10 +128,10 @@ homeUser uid = do cTime <- liftIO getCurrentTime let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime - tableData :: -- E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) - -- (E.SqlExpr (Entity Course ))) - -- (E.SqlExpr (Entity Sheet )) - _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) + tableData :: E.LeftOuterJoin + (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) + (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser)))) + -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) , E.SqlExpr (E.Value SchoolId) , E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value SheetName) @@ -207,11 +218,11 @@ homeUser uid = do , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } - addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." + -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." defaultLayout $ do -- setTitle "Willkommen zum Uni2work Test!" $(widgetFile "homeUser") - $(widgetFile "dsgvDisclaimer") + -- $(widgetFile "dsgvDisclaimer") getVersionR :: Handler TypedContent @@ -224,3 +235,79 @@ getVersionR = selectRep $ do $(widgetFile "versionHistory") provideRep $ return ($gitDescribe :: Text) + + + + +data HelpIdentOptions = HIUser | HIEmail | HIAnonymous + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 +instance Universe HelpIdentOptions where universe = universeDef +instance Finite HelpIdentOptions + +instance PathPiece HelpIdentOptions where + toPathPiece = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX HelpIdentOptions where + renderMessage foundation ls = renderMessage foundation ls . \case + HIUser -> MsgHelpUser + HIEmail -> MsgHelpEMail + HIAnonymous -> MsgHelpAnonymous + +data HelpForm = HelpForm + { hfReferer:: Maybe Text + , hfUserId :: Either (Maybe Email) UserId + , hfRequest:: Text + } + +helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm +helpForm mReferer mUid = HelpForm + <$> maybe (pure Nothing) (fmap Just . aforced textField (fslI MsgHelpProblemPage)) mReferer + <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) + <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) + <* submitButton + where + identActions :: Map _ (AForm _ (Either (Maybe Email) UserId)) + identActions = Map.fromList $ case mUid of + (Just uid) -> (HIUser, pure $ Right uid):defaultActions + Nothing -> defaultActions + + defaultActions = + [ (HIEmail, Left . Just <$> apreq emailField (fslI MsgEMail) Nothing) + , (HIAnonymous, pure $ Left Nothing) + ] + +getHelpR :: Handler Html +getHelpR = postHelpR + +postHelpR :: Handler Html +postHelpR = do + mUid <- maybeAuthId + mRefererBS <- requestHeaderReferer <$> waiRequest + let mReferer = maybeRight . decodeUtf8' =<< mRefererBS + + ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid + + case res of + FormSuccess (HelpForm{..}) -> do + now <- liftIO getCurrentTime + queueJob' $ JobHelpRequest { jSender = hfUserId + , jHelpRequest = hfRequest + , jRequestTime = now + , jReferer = hfReferer } + -- redirect $ HelpR + addMessageI Success MsgHelpSent + return () + {-selectRep $ do + provideJson () + provideRep (redirect $ HelpR :: Handler Html) -} + FormMissing -> return () + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs + + defaultLayout $ do + setTitle "Hilfe" -- TODO: International + $(widgetFile "help") + + diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 874971fec..86e03d26e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -24,6 +24,8 @@ import Utils.Lens -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map +import Data.Map ((!)) +import qualified Data.Set as Set -- import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -37,6 +39,7 @@ data SettingsForm = SettingsForm , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool + , stgNotificationSettings :: NotificationSettings } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm @@ -53,13 +56,30 @@ makeSettingForm template = identForm FIDsettings $ \html -> do <*> areq checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) + <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty) <* submitButton return (result, widget) -- no validation required here + where + nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt -> + areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template) + nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX]) + nsFieldView (res, fvInput) = do + mr <- getMessageRender + let fvLabel = toHtml $ mr MsgNotificationSettings + fvTooltip = mempty + fvRequired = True + fvErrors + | FormFailure (err:_) <- res = Just $ toHtml err + | otherwise = Nothing + fvId <- newIdent + return (res, pure FieldView{..}) + -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) -getProfileR :: Handler Html -getProfileR = do +getProfileR, postProfileR :: Handler Html +getProfileR = postProfileR +postProfileR = do (uid, User{..}) <- requireAuthPair let settingsTemplate = Just $ SettingsForm { stgMaxFavourties = userMaxFavourites @@ -68,6 +88,7 @@ getProfileR = do , stgDate = userDateFormat , stgTime = userTimeFormat , stgDownloadFiles = userDownloadFiles + , stgNotificationSettings = userNotificationSettings } ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate case res of @@ -79,6 +100,7 @@ getProfileR = do , UserDateFormat =. stgDate , UserTimeFormat =. stgTime , UserDownloadFiles =. stgDownloadFiles + , UserNotificationSettings =. stgNotificationSettings ] when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size @@ -93,52 +115,11 @@ getProfileR = do (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml _ -> return () - - (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$> - (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do - E.where_ $ adright E.^. UserAdminUser E.==. E.val uid - E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId - return (school E.^. SchoolShorthand) - ) - <*> - (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do - E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid - E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId - return (school E.^. SchoolShorthand) - ) - <*> - (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet - E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid - return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) - ) - <*> - (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid - E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId - E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId - return ( ( studydegree E.^. StudyDegreeName - , studydegree E.^. StudyDegreeKey - ) - , ( studyterms E.^. StudyTermsName - , studyterms E.^. StudyTermsKey - ) - , studyfeat E.^. StudyFeaturesType - , studyfeat E.^. StudyFeaturesSemester) - ) - let formText = Just MsgSettings - actionUrl = ProfileR - settingsForm = $(widgetFile "formPageI18n") + let formText = Nothing :: Maybe UniWorXMessage + actionUrl = ProfileR defaultLayout $ do setTitle . toHtml $ userIdent <> "'s User page" - $(widgetFile "profile") - $(widgetFile "dsgvDisclaimer") - -postProfileR :: Handler Html -postProfileR = do - -- TODO - getProfileR + $(widgetFile "formPageI18n") postProfileDataR :: Handler Html postProfileDataR = do @@ -146,17 +127,69 @@ postProfileDataR = do case btnResult of (FormSuccess BtnDelete) -> do (uid, User{..}) <- requireAuthPair - addMessage Warning "Delete-Knopf gedrückt" - addMessage Error "Löschen der Daten wurde noch nicht implementiert." - -- first determine all submission that solely depend on this user: - -- SubmissionGroup / SubmissionGroupUser - -- Submission / SubmissionUser - -- runDB $ deleteCascade uid + clearCreds False -- Logout-User + ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid + -- addMessageIHamlet + $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE + -- addMessageI Success $ MsgDeleteUser deletedSubmissions + -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions + defaultLayout $ do + $(widgetFile "deletedUser") + (FormSuccess BtnAbort ) -> do addMessageI Info MsgAborted redirect ProfileDataR - _other -> return () - getProfileDataR + _other -> getProfileDataR + + + +deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration +deleteUser duid = do + -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually + -- We delete all files tied to submissions where the user is the lone submissionUser + + -- Do not deleteCascade submissions where duid is the corrector: + updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing] + + groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) + singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) + deleteCascade duid + forM_ singleSubmissions $ \(E.Value submissionId) -> do + deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId + deleteCascade submissionId + deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files + + deletedSubmissionGroups <- deleteSingleSubmissionGroups + return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) + where + selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)] + selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do + E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission + let numBuddies = E.sub_select $ E.from $ \subUsers -> do + E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid + return E.countRows + E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid + E.&&. (whereBuddies numBuddies) + return $ submission E.^. SubmissionId + + getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)] + getSubmissionFiles subId = E.select $ E.from $ \file -> do + E.where_ $ E.exists $ E.from $ \submissionFile -> do + E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId + E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId + return $ file E.^. FileId + + deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do + E.where_ $ E.exists $ E.from $ \subGroupUser -> do + E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid + E.where_ $ E.notExists $ E.from $ \subGroupUser -> do + E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid + + + @@ -164,6 +197,39 @@ getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair -- mr <- getMessageRender + (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$> + (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do + E.where_ $ adright E.^. UserAdminUser E.==. E.val uid + E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId + return (school E.^. SchoolShorthand) + ) + <*> + (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do + E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid + E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId + return (school E.^. SchoolShorthand) + ) + <*> + (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid + return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) + ) + <*> + (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do + E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId + E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + return ( ( studydegree E.^. StudyDegreeName + , studydegree E.^. StudyDegreeKey + ) + , ( studyterms E.^. StudyTermsName + , studyterms E.^. StudyTermsKey + ) + , studyfeat E.^. StudyFeaturesType + , studyfeat E.^. StudyFeaturesSemester) + ) -- Tabelle mit eigenen Kursen (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 510e92117..e001b3a84 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,6 +13,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} module Handler.Sheet where @@ -48,6 +48,8 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT) -- import qualified Data.List as List +import Control.Monad.Trans.Except (ExceptT(..), runExceptT, mapExceptT, throwE) + import Network.Mime import Data.Set (Set) @@ -57,11 +59,17 @@ import qualified Data.Map as Map import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map -import Data.Monoid (Sum(..)) +import Data.Monoid (Sum(..), Any(..)) import Control.Lens -- import Utils.Lens +import qualified Data.Text as Text +import qualified Data.Aeson as Aeson + +import Control.Monad.Random.Class (MonadRandom(..)) +import Utils.Sql + instance Eq (Unique Sheet) where (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = @@ -77,11 +85,11 @@ data SheetForm = SheetForm { sfName :: SheetName , sfDescription :: Maybe Html , sfType :: SheetType - , sfGrouping :: SheetGroup - , sfMarkingText :: Maybe Html + , sfGrouping :: SheetGroup , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime + , sfSubmissionMode :: SheetSubmissionMode , sfUploadMode :: UploadMode , sfSheetF :: Maybe (Source Handler (Either FileId File)) , sfHintFrom :: Maybe UTCTime @@ -89,6 +97,7 @@ data SheetForm = SheetForm , sfSolutionFrom :: Maybe UTCTime , sfSolutionF :: Maybe (Source Handler (Either FileId File)) , sfMarkingF :: Maybe (Source Handler (Either FileId File)) + , sfMarkingText :: Maybe Html -- Keine SheetId im Formular! } @@ -111,8 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <$> areq ciField (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template) - <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) - <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) + <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime)) @@ -120,6 +128,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) + <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions) <*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True)) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" @@ -131,6 +140,7 @@ makeSheetForm msId template = identForm 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) <* submitButton return $ case result of FormSuccess sheetResult @@ -149,7 +159,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do ] ] getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getSheetListR tid ssh csh = do +getSheetListR tid ssh csh = do muid <- maybeAuthId Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh let @@ -244,6 +254,21 @@ getSheetListR tid ssh csh = do $(widgetFile "sheetList") $(widgetFile "widgets/sheetTypeSummary") +data ButtonGeneratePseudonym = BtnGenerate + deriving (Enum, Eq, Ord, Bounded, Read, Show) +instance Universe ButtonGeneratePseudonym +instance Finite ButtonGeneratePseudonym + +$(return []) + +instance PathPiece ButtonGeneratePseudonym where + toPathPiece = $(nullaryToPathPiece ''ButtonGeneratePseudonym [Text.unwords . drop 1 . splitCamel]) + fromPathPiece = finiteFromPathPiece + +instance Button UniWorX ButtonGeneratePseudonym where + label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] + cssClass BtnGenerate = BCDefault + -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do @@ -273,14 +298,14 @@ getSShowR tid ssh csh shn = do -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def & defaultSorting [("type", SortAsc), ("path", SortAsc)] - ((), fileTable) <- dbTable psValidator $ DBTable + (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } @@ -288,16 +313,17 @@ getSShowR tid ssh csh shn = do , dbtStyle = def , dbtFilter = Map.empty , dbtIdent = "files" :: Text - , dbtSorting = [ ( "type" - , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType - ) - , ( "path" - , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle - ) - , ( "time" - , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified - ) - ] + , dbtSorting = Map.fromList + [ ( "type" + , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType + ) + , ( "path" + , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle + ) + , ( "time" + , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified + ) + ] } (hasHints, hasSolution) <- runDB $ do hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] @@ -307,6 +333,12 @@ getSShowR tid ssh csh shn = do visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $ maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom + mPseudonym <- runMaybeT $ do + uid <- MaybeT maybeAuthId + Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid + return . Text.unwords . map CI.original $ review pseudonymWords sheetPseudonymPseudonym + (generateWidget, generateEnctype) <- generateFormPost $ \csrf -> + over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing defaultLayout $ do setTitleI $ MsgSheetTitle tid ssh csh shn sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet @@ -315,6 +347,32 @@ getSShowR tid ssh csh shn = do solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet $(widgetFile "sheetShow") +postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent +getSPseudonymR = postSPseudonymR +postSPseudonymR tid ssh csh shn = do + uid <- requireAuthId + shId <- runDB $ fetchSheetId tid ssh csh shn + let + genPseudonym = do + inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do + candidate <- liftIO getRandom + existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid + case existing of + Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym + Nothing + -> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid) + case inserted of + Right Nothing -> genPseudonym + Right (Just ps) -> return ps + Left ps -> return ps + ps <- genPseudonym + let ps' = Text.unwords . map CI.original $ review pseudonymWords ps + selectRep $ do + provideRep $ return ps' + provideJson ps + provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html) + + getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR tid ssh csh shn typ title = do results <- runDB $ E.select $ E.from $ @@ -361,11 +419,11 @@ getSheetNewR tid ssh csh = do { sfName = stepTextCounterCI sheetName , sfDescription = sheetDescription , sfType = sheetType - , sfGrouping = sheetGrouping - , sfMarkingText = sheetMarkingText + , sfGrouping = sheetGrouping , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom , sfActiveFrom = addOneWeek sheetActiveFrom , sfActiveTo = addOneWeek sheetActiveTo + , sfSubmissionMode = sheetSubmissionMode , sfUploadMode = sheetUploadMode , sfSheetF = Nothing , sfHintFrom = addOneWeek <$> sheetHintFrom @@ -373,6 +431,7 @@ getSheetNewR tid ssh csh = do , sfSolutionFrom = addOneWeek <$> sheetSolutionFrom , sfSolutionF = Nothing , sfMarkingF = Nothing + , sfMarkingText = sheetMarkingText } _other -> Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing @@ -395,11 +454,11 @@ getSEditR tid ssh csh shn = do { sfName = sheetName , sfDescription = sheetDescription , sfType = sheetType - , sfGrouping = sheetGrouping - , sfMarkingText = sheetMarkingText + , sfGrouping = sheetGrouping , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo + , sfSubmissionMode = sheetSubmissionMode , sfUploadMode = sheetUploadMode , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom @@ -407,6 +466,7 @@ getSEditR tid ssh csh shn = do , sfSolutionFrom = sheetSolutionFrom , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking + , sfMarkingText = sheetMarkingText } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet @@ -441,6 +501,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetHintFrom = sfHintFrom , sheetSolutionFrom = sfSolutionFrom , sheetUploadMode = sfUploadMode + , sheetSubmissionMode = sfSubmissionMode } mbsid <- dbAction newSheet case mbsid of diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b64be4126..b8f80cbee 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -20,6 +20,8 @@ module Handler.Submission where import Import hiding (joinPath) +import Jobs + -- import Yesod.Form.Bootstrap3 import Handler.Utils @@ -72,7 +74,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ flip (renderAForm FormStandard) html $ (,) <$> fileUpload <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy - | g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile + | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies ]) <* submitButton @@ -178,7 +180,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (csheet,buddies,lastEdits) ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies - mCID <- runDB $ do + mCID <- runDBJobs $ do res' <- case res of (FormMissing ) -> return $ FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs @@ -215,7 +217,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email _other -> mempty - , case length participants `compare` maxParticipants of + , case fromIntegral (length participants) `compare` maxParticipants of LT -> mempty _ -> pure $ mr MsgTooManyParticipants ] @@ -232,8 +234,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do smid <- case (mFiles, msmid) of (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid - (Just files, _) -- new files - -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False + (Just files, _) -> -- new files + runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> insert Submission { submissionSheet = shid diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs new file mode 100644 index 000000000..5158e65f6 --- /dev/null +++ b/src/Handler/SystemMessage.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + , NamedFieldPuns + , RecordWildCards + , OverloadedStrings + , TypeFamilies + , ViewPatterns + , FlexibleContexts + , LambdaCase + , MultiParamTypeClasses + #-} + +module Handler.SystemMessage where + +import Import + +import qualified Data.Map.Lazy as Map +import qualified Data.Text as Text + +import qualified Data.Set as Set + +import qualified Data.List.NonEmpty as NonEmpty + +import Handler.Utils + +import Utils.Lens + + +htmlField' :: Field (HandlerT UniWorX IO) Html +htmlField' = htmlField + { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis + } + + + +getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html +getMessageR = postMessageR +postMessageR cID = do + smId <- decrypt cID + (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId + let (summary, content) = case translation of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + + let + mkForm :: Handler (((FormResult SystemMessage, Widget), Enctype), Map Lang ((FormResult (Entity SystemMessageTranslation, [Maybe BtnSubmitDelete]), Widget), Enctype), ((FormResult SystemMessageTranslation, Widget), Enctype)) + mkForm = do + modifyRes'@((modifyRes, _), _) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard + $ SystemMessage + <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom) + <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo) + <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly) + <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity) + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage) + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent) + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary) + <* submitButton + + ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage] + let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts + + modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do + cID' <- encrypt tId + runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard + $ (,) + <$> ( fmap (Entity tId) $ SystemMessageTranslation + <$> pure systemMessageTranslationMessage + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage) + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent) + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary) + ) + <*> combinedButtonField (universeF :: [BtnSubmitDelete]) + + let modifyTranss = Map.map (view $ _1._1) modifyTranss' + + addTransRes'@((addTransRes, _), _) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard + $ SystemMessageTranslation + <$> pure smId + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing + <* submitButton + + formResult modifyRes $ \SystemMessage{..} -> do + runDB $ update smId + [ SystemMessageFrom =. systemMessageFrom + , SystemMessageTo =. systemMessageTo + , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly + , SystemMessageSeverity =. systemMessageSeverity + , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage + , SystemMessageContent =. systemMessageContent + , SystemMessageSummary =. systemMessageSummary + ] + addMessageI Success MsgSystemMessageEditSuccess + redirect $ MessageR cID + + formResult addTransRes $ \smt -> do + runDB . void . insert $ smt + addMessageI Success MsgSystemMessageAddTranslationSuccess + redirect $ MessageR cID + + forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of + [BtnDelete'] -> do + runDB $ delete tId + addMessageI Success MsgSystemMessageDeleteTranslationSuccess + redirect $ MessageR cID + _other -> do + runDB $ update tId + [ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage + , SystemMessageTranslationContent =. systemMessageTranslationContent + , SystemMessageTranslationSummary =. systemMessageTranslationSummary + ] + addMessageI Success MsgSystemMessageEditTranslationSuccess + redirect $ MessageR cID + + return (modifyRes', modifyTranss', addTransRes') + + maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True + forms <- traverse (const mkForm) $ () <$ guard maySubmit + + defaultLayout $ do + $(widgetFile "system-message") + + +type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation) + +data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate + deriving (Eq, Ord, Enum, Bounded, Show, Read) +instance Universe ActionSystemMessage +instance Finite ActionSystemMessage +$(return []) +instance PathPiece ActionSystemMessage where + toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX ActionSystemMessage where + renderMessage m ls = renderMessage m ls . \case + SMDelete -> MsgSystemMessageDelete + SMActivate -> MsgSystemMessageActivate + SMDeactivate -> MsgSystemMessageDeactivate + +data ActionSystemMessageData = SMDDelete + | SMDActivate (Maybe UTCTime) + | SMDDeactivate (Maybe UTCTime) + deriving (Eq, Show, Read) + +getMessageListR, postMessageListR :: Handler Html +getMessageListR = postMessageListR +postMessageListR = do + let + dbtSQLQuery = return + dbtColonnade = mconcat + [ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId + , dbRow + , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext) + , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom + , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo + , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly + , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity + , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let + (summary, content) = case smT of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + in cell . toWidget $ fromMaybe content summary + ] + dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do + Just (_, smT) <- lift $ getSystemMessage appLanguages smId + return $ DBRow + { dbrOutput = (smE, smT) + , .. + } + psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) + tableForm <- dbTable psValidator $ DBTable + { dbtSQLQuery + , dbtColonnade + , dbtProj + , dbtSorting = Map.fromList + [ -- TODO: from, to, authenticated, severity + ] + , dbtFilter = Map.fromList + [ + ] + , dbtStyle = def + , dbtIdent = "messages" :: Text + } + ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do + ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf + now <- liftIO $ getCurrentTime + let actions = Map.fromList + [ (SMDelete, pure SMDDelete) + , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) + , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing)) + ] + (actionRes, action) <- multiAction actions (Just SMActivate) + $logDebugS "SystemMessage" $ tshow (actionRes, selectionRes) + return ((,) <$> actionRes <*> selectionRes, table <> action) + + case tableRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess (SMDDelete, selection) + | not $ null selection -> do + selection' <- traverse decrypt $ Set.toList selection + runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ] + $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet") + redirect MessageListR + FormSuccess (SMDActivate ts, selection) + | not $ null selection -> do + selection' <- traverse decrypt $ Set.toList selection + runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ] + $(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet") + redirect MessageListR + FormSuccess (SMDDeactivate ts, selection) + | not $ null selection -> do + selection' <- traverse decrypt $ Set.toList selection + runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ] + $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet") + redirect MessageListR + FormSuccess (_, selection) + | null selection -> addMessageI Error MsgSystemMessageEmptySelection + + ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage + <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing + <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing + <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing + <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) Nothing + <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages) + <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing + <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing + <* submitButton + + case addRes of + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + FormSuccess sysMsg -> do + sId <- runDB $ insert sysMsg + cID <- encrypt sId :: Handler CryptoUUIDSystemMessage + addMessageI Success $ MsgSystemMessageAdded cID + redirect $ MessageR cID + + defaultLayout $ do + $(widgetFile "system-message-list") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 394359b27..1b3d68334 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -25,6 +25,7 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Submission as Handler.Utils import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Templates as Handler.Utils +import Handler.Utils.Mail as Handler.Utils downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 679539202..67acd6a32 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -11,6 +11,7 @@ module Handler.Utils.DateTime , formatTime, formatTime', formatTimeW , getTimeLocale, getDateTimeFormat , validDateTimeFormats, dateTimeFormatOptions + , formatTimeMail , addOneWeek ) where @@ -26,6 +27,8 @@ import qualified Data.Time.Format as Time import Data.Set (Set) import qualified Data.Set as Set +import Mail + utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime = TZ.utcToLocalTimeTZ appTZ @@ -58,6 +61,9 @@ formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeForm formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget formatTimeW s t = toWidget =<< formatTime s t +formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text +formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t) + getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale getTimeLocale = getTimeLocale' <$> languages diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index c5ba85946..c7b7aee21 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -25,7 +25,7 @@ import Handler.Utils.Templates import Handler.Utils.DateTime import qualified Data.Time as Time -import Import +import Import hiding (cons) import qualified Data.Char as Char import Data.String (IsString(..)) @@ -60,6 +60,10 @@ import Data.Scientific (Scientific) import Data.Ratio import Text.Read (readMaybe) +import Data.Maybe (fromJust) + +import Utils.Lens + ---------------------------- -- Buttons (new version ) -- ---------------------------- @@ -104,6 +108,25 @@ instance Button UniWorX AdminHijackUserButton where cssClass BtnHijack = BCDefault +data BtnSubmitDelete = BtnSubmit' | BtnDelete' + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance Universe BtnSubmitDelete +instance Finite BtnSubmitDelete + +instance Button UniWorX BtnSubmitDelete where + label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|] + label BtnDelete' = [whamlet|_{MsgBtnDelete}|] + + cssClass BtnSubmit' = BCPrimary + cssClass BtnDelete' = BCDanger + +$(return []) + +instance PathPiece BtnSubmitDelete where + toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ]) + fromPathPiece = finiteFromPathPiece + -- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- data LinkButton = LinkButton (Route UniWorX) @@ -121,37 +144,6 @@ linkButton lbl cls url = [whamlet| - {- -combinedButtonField :: Button a => [a] -> Form m -> Form (a,m) -combinedButtonField btns inner csrf = do - buttonIdent <- newFormIdent - let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing - (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - (innerRes,innerWdgt) <- inner - let widget = do - [whamlet| - #{csrf} - ^{innerWdgt} -
- $forall bView <- btnViews - ^{fvInput bView} - |] - let result = case (accResult result, innerRes) of - (FormSuccess b, FormSuccess i) -> FormSuccess (b,i) - _ -> FormFailure ["Something went wrong"] -- TODO - return (result,widget) - where - accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a - accResult = Foldable.foldr accResult' FormMissing - - accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] - accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? - accResult' (FormSuccess Nothing) x = x - accResult' FormMissing _ = FormMissing - accResult' (FormFailure errs) _ = FormFailure errs - -} -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) buttonForm :: (Button UniWorX a, Show a) => Form a @@ -165,18 +157,16 @@ buttonForm csrf = do $forall bView <- btnViews ^{fvInput bView} |] - $logDebugS "FormResult" $ tshow results return (accResult results,widget) where accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a accResult = Foldable.foldr accResult' FormMissing accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - -- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one! - -- TODO: Maybe change buttonField? + -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one. accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? + accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess accResult' (FormSuccess Nothing) x = x accResult' FormMissing _ = FormMissing accResult' (FormFailure errs) _ = FormFailure errs @@ -257,6 +247,22 @@ uploadModeField = selectFieldList , (MsgUploadModeUnpack , Upload True ) ] +submissionModeField :: Field Handler SheetSubmissionMode +submissionModeField = selectFieldList + [ (MsgSheetNoSubmission, NoSubmissions) + , (MsgSheetCorrectorSubmissions, CorrectorSubmissions) + , (MsgSheetUserSubmissions, UserSubmissions) + ] + +pseudonymWordField :: Field Handler PseudonymWord +pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist) + where + doCheck (CI.mk -> w) + | Just w' <- find (== w) pseudonymWordlist + = return $ Right w' + | otherwise + = return . Left $ MsgUnknownPseudonymWord (CI.original w) + zipFileField :: Bool -- ^ Unpack zips? -> Field Handler (Source Handler File) zipFileField doUnpack = Field{..} @@ -321,23 +327,122 @@ multiFileField permittedFiles' = Field{..} Right _ -> return () Left r -> yield r -sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType -sheetTypeAFormReq d Nothing = - -- TODO, offer options to choose between Normal/Bonus/Pass - (Normal . toPoints) <$> areq (natField "Punkte") d Nothing -sheetTypeAFormReq d (Just (Normal p)) = - -- TODO, offer options to choose between Normal/Bonus/Pass - (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p) -sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded +data SheetType' = Bonus' | Normal' | Pass' | NotGraded' + deriving (Eq, Ord, Read, Show, Enum, Bounded) +instance Universe SheetType' +instance Finite SheetType' + +$(return []) + +instance PathPiece SheetType' where + toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX SheetType' where + renderMessage f ls = \case + Bonus' -> render MsgSheetTypeBonus + Normal' -> render MsgSheetTypeNormal + Pass' -> render MsgSheetTypePass + NotGraded' -> render MsgSheetTypeNotGraded + where + render = renderMessage f ls + +data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +instance Universe SheetGroup' +instance Finite SheetGroup' + +$(return []) + +instance PathPiece SheetGroup' where + toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX SheetGroup' where + renderMessage f ls = \case + Arbitrary' -> render MsgSheetGroupArbitrary + RegisteredGroups' -> render MsgSheetGroupRegisteredGroups + NoGroups' -> render MsgSheetGroupNoGroups + where + render = renderMessage f ls + +sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType +sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do + let + selOptions = Map.fromList + [ ( Bonus', Bonus <$> maxPointsReq ) + , ( Normal', Normal <$> maxPointsReq ) + , ( Pass', Pass + <$> maxPointsReq + <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template) + ) + , ( NotGraded', pure NotGraded ) + ] + (res, selView) <- multiAction selOptions (classify' <$> template) + + fvId <- maybe newIdent return fsId + MsgRenderer mr <- getMsgRenderer + + return (res, + [ FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml . mr <$> fsTooltip + , fvId + , fvInput = selView + , fvErrors = case res of + FormFailure [e] -> Just $ toHtml e + _ -> Nothing + , fvRequired = True + } + ]) + + where + maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template) + + classify' :: SheetType -> SheetType' + classify' = \case + Bonus _ -> Bonus' + Normal _ -> Normal' + Pass _ _ -> Pass' + NotGraded -> NotGraded' sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup -sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 = - -- TODO, offer options to choose between Arbitrary/Registered/NoGroups - Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n) -sheetGroupAFormReq d _other = -- TODO - -- TODO, offer options to choose between Arbitrary/Registered/NoGroups - Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1) +sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do + let + selOptions = Map.fromList + [ ( Arbitrary', Arbitrary + <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) + ) + , ( RegisteredGroups', pure RegisteredGroups ) + , ( NoGroups', pure NoGroups ) + ] + (res, selView) <- multiAction selOptions (classify' <$> template) + + fvId <- maybe newIdent return fsId + MsgRenderer mr <- getMsgRenderer + + return (res, + [ FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml . mr <$> fsTooltip + , fvId + , fvInput = selView + , fvErrors = case res of + FormFailure [e] -> Just $ toHtml e + _ -> Nothing + , fvRequired = True + } + ]) + + where + classify' :: SheetGroup -> SheetGroup' + classify' = \case + Arbitrary _ -> Arbitrary' + RegisteredGroups -> RegisteredGroups' + NoGroups -> NoGroups' + {- dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime @@ -385,6 +490,11 @@ utcTimeField = Field (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime Nothing -> Left MsgInvalidDateTimeFormat +langField :: Bool -- ^ Only allow values from `appLanguages` + -> Field (HandlerT UniWorX IO) Lang +langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages) +langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages + fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm = bfs -- TODO: get rid of Bootstrap @@ -449,15 +559,61 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m => Field m a -> FieldSettings site -> a -> AForm m a aforced field settings val = formToAForm $ second pure <$> mforced field settings val +apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> AForm m a +-- ^ Pseudo required +apreq f fs mx = formToAForm $ do + mr <- getMessageRender + fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx) + +wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) +wpreq f fs mx = mFormToWForm $ do + mr <- getMessageRender + fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx) + multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget)) + => Map action (AForm (HandlerT UniWorX IO) a) + -> Maybe action -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) -multiAction acts = do +multiAction acts defAction = do mr <- getMessageRender let options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece - (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing - results <- sequence acts - let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results + (actionRes, actionView) <- mreq (selectField $ return options) "" defAction + results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts + let mToWidget (_, []) = return Nothing + mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty + widgets <- mapM mToWidget results + let actionWidgets = Map.foldrWithKey accWidget [] widgets + accWidget act Nothing = id + accWidget act (Just w) = cons $(widgetFile "widgets/multiAction") actionResults = Map.map fst results return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect")) + +multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) + => FieldSettings UniWorX + -> Map action (AForm (HandlerT UniWorX IO) a) + -> Maybe action + -> AForm (HandlerT UniWorX IO) a +multiActionA FieldSettings{..} acts defAction = formToAForm $ do + (res, selView) <- multiAction acts defAction + + fvId <- maybe newIdent return fsId + MsgRenderer mr <- getMsgRenderer + + return (res, + [ FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml . mr <$> fsTooltip + , fvId + , fvInput = selView + , fvErrors = case res of + FormFailure [e] -> Just $ toHtml e + _ -> Nothing + , fvRequired = True + } + ]) + + + diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs new file mode 100644 index 000000000..96ef448e0 --- /dev/null +++ b/src/Handler/Utils/Mail.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NoImplicitPrelude + , NamedFieldPuns + , TypeFamilies + , FlexibleContexts + , ViewPatterns + , LambdaCase + #-} + +module Handler.Utils.Mail + ( addRecipientsDB + , userMailT + , addFileDB + ) where + +import Import hiding ((.=)) + +import Utils.Lens hiding (snoc) + +import qualified Data.CaseInsensitive as CI + +import qualified Data.ByteString.Lazy as LBS + +import qualified Data.Conduit.List as C + +import System.FilePath (takeBaseName) +import Network.Mime (defaultMimeLookup) + +import Control.Monad.Trans.State (StateT) + + +addRecipientsDB :: ( MonadMail m + , MonadHandler m + , HandlerSite m ~ UniWorX + ) => [Filter User] -> m () +-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user +addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient + where + addRecipient (Entity _ User{userEmail, userDisplayName}) = do + let addr = Address (Just userDisplayName) $ CI.original userEmail + _mailTo %= flip snoc addr + +userMailT :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadBaseControl IO m + , MonadLogger m + ) => UserId -> MailT m a -> m a +userMailT uid mAct = do + User + { userEmail + , userDisplayName + , userMailLanguages + , userDateTimeFormat + , userDateFormat + , userTimeFormat + } <- liftHandlerT . runDB $ getJust uid + let + addr = Address (Just userDisplayName) $ CI.original userEmail + ctx = MailContext + { mcLanguages = userMailLanguages + , mcDateTimeFormat = \case + SelFormatDateTime -> userDateTimeFormat + SelFormatDate -> userDateFormat + SelFormatTime -> userTimeFormat + } + mailT ctx $ do + _mailTo .= pure addr + mAct + +addFileDB :: ( MonadMail m + , MonadHandler m + , HandlerSite m ~ UniWorX + ) => FileId -> m MailObjectId +addFileDB fId = do + File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId + addPart $ do + _partType .= decodeUtf8 (defaultMimeLookup fileName) + _partEncoding .= Base64 + _partFilename .= Just fileName + _partContent .= LBS.fromStrict fileContent + setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 32b9e4d65..9f67bf0e0 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} module Handler.Utils.Submission @@ -25,6 +26,7 @@ module Handler.Utils.Submission ) where import Import hiding ((.=), joinPath) +import Jobs import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) @@ -38,7 +40,7 @@ import Control.Monad.RWS.Lazy (RWST) import qualified Control.Monad.Random as Rand import qualified System.Random.Shuffle as Rand (shuffleM) -import Data.Maybe +import Data.Maybe () import qualified Data.List as List import Data.Set (Set) @@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do data SubmissionSinkState = SubmissionSinkState { sinkSeenRating :: Any , sinkSubmissionTouched :: Any + , sinkSubmissionNotifyRating :: Any , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) @@ -333,7 +336,7 @@ extractRatingsMsg = do sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId + -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied -- 'SubmissionContent'. @@ -365,7 +368,7 @@ sinkSubmission userId mExists isUpdate = do sinkSubmission' :: SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) () + -> Sink SubmissionContent (YesodJobDB UniWorX) () sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -463,18 +466,21 @@ sinkSubmission userId mExists isUpdate = do -- The check whether the new version matches the underlying file is -- more lenient, considering only filename and -content. - touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) () + touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) () touchSubmission = do alreadyTouched <- gets $ getAny . sinkSubmissionTouched when (not alreadyTouched) $ do now <- liftIO getCurrentTime - lift $ case isUpdate of - False -> insert_ $ SubmissionEdit userId now submissionId - True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] - -- TODO: Should submissionRatingAssigned change here if userId changes? + case isUpdate of + False -> lift . insert_ $ SubmissionEdit userId now submissionId + True -> do + Submission{submissionRatingTime} <- lift $ getJust submissionId + when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True } + lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] + -- TODO: Should submissionRatingAssigned change here if userId changes? tell $ mempty{ sinkSubmissionTouched = Any True } - finalize :: SubmissionSinkState -> YesodDB UniWorX () + finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize SubmissionSinkState{..} = do missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId @@ -509,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ] deleteCascade fileId - when (isUpdate && not (getAny sinkSeenRating)) $ - update submissionId + if + | isUpdate + , not $ getAny sinkSeenRating + -> update submissionId [ SubmissionRatingTime =. Nothing , SubmissionRatingPoints =. Nothing , SubmissionRatingBy =. Nothing , SubmissionRatingComment =. Nothing ] + | isUpdate + , getAny sinkSubmissionNotifyRating + -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId + | otherwise -> return () data SubmissionMultiSinkException = SubmissionSinkException @@ -529,7 +541,7 @@ instance Exception SubmissionMultiSinkException sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} - -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId) + -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- @@ -543,8 +555,8 @@ sinkMultiSubmission userId isUpdate = do -> RWST () _ - (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) - (YesodDB UniWorX) + (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId)) + (YesodJobDB UniWorX) () feed sId val = do mSink <- gets $ Map.lookup sId @@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do when (not $ null ignored) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) - fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do + lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do cID <- encrypt sId handle (throwM . SubmissionSinkException cID Nothing) $ - void $ closeResumableSink sink + closeResumableSink sink where handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a) handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3e017472c..ff2e81f64 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM, anchorCellM' - , tickmarkCell + , tickmarkCell, cellTooltip , listCell , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect @@ -339,8 +339,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) - dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent - dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf + dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost + dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) @@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a tickmarkCell True = textCell (tickmark :: Text) tickmarkCell False = mempty +cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a +cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt) + where + tipWdgt = [whamlet| +
+
+
_{msg} + |] + anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return diff --git a/src/Import.hs b/src/Import.hs index cdb0ec16f..27dc6e5df 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -5,3 +5,4 @@ module Import import Foundation as Import import Import.NoFoundation as Import +import Utils.SystemMessage as Import diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 8db4ec779..45c6c2d6a 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module Import.NoFoundation ( module Import + , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import @@ -13,6 +14,7 @@ import Yesod.Auth as Import import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import import Utils as Import +import Yesod.Core.Json as Import (provideJson) import Data.Fixed as Import @@ -25,3 +27,21 @@ import Text.Lucius as Import import Text.Shakespeare.Text as Import hiding (text, stext) import Data.Universe as Import +import Data.Pool as Import (Pool) +import Network.HaskellNet.SMTP as Import (SMTPConnection) + +import Mail as Import + +import Data.Data as Import (Data) +import Data.Typeable as Import (Typeable) +import GHC.Generics as Import (Generic) + +import Data.Hashable as Import +import Data.List.NonEmpty as Import (NonEmpty(..)) + +import Control.Monad.Morph as Import (MFunctor(..)) + + +import Control.Monad.Trans.RWS (RWST) + +type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m diff --git a/src/Jobs.hs b/src/Jobs.hs new file mode 100644 index 000000000..f89265009 --- /dev/null +++ b/src/Jobs.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + , OverloadedStrings + , FlexibleContexts + , ViewPatterns + , TypeFamilies + , DeriveGeneric + , DeriveDataTypeable + , QuasiQuotes + , NamedFieldPuns + , MultiWayIf + #-} + +module Jobs + ( module Types + , module Jobs.Queue + , handleJobs + ) where + +import Import hiding (Proxy) + +import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) +import Jobs.Types (JobCtl(JobCtlQueue)) +import Jobs.Queue +import Jobs.TH +import Jobs.Crontab + +import Data.Conduit.TMChan +import qualified Data.Conduit.List as C + +import qualified Data.Text.Lazy as LT + +import Data.Aeson (fromJSON, toJSON) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Database.Persist.Sql (fromSqlKey) + +import Data.Semigroup (Max(..)) + +import Utils.Sql + +import Control.Monad.Random (evalRand, mkStdGen) + +import Cron +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (HashMap) + +import qualified Data.List.NonEmpty as NonEmpty + +import Data.Foldable (foldrM) + +import Control.Monad.Trans.Reader (mapReaderT) +import Control.Monad.Trans.State (StateT, evalStateT, mapStateT) +import qualified Control.Monad.State.Class as State +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Logger + +import Control.Monad.Random (MonadRandom(..), evalRand) + +import Data.Time.Clock +import Data.Time.Zones + +import Control.Concurrent.STM (retry) + + +import Jobs.Handler.SendNotification +import Jobs.Handler.SendTestEmail +import Jobs.Handler.QueueNotification +import Jobs.Handler.HelpRequest +import Jobs.Handler.SetLogSettings + + +data JobQueueException = JInvalid QueuedJobId QueuedJob + | JLocked QueuedJobId InstanceId UTCTime + | JNonexistant QueuedJobId + deriving (Read, Show, Eq, Generic, Typeable) + +instance Exception JobQueueException + + +handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m () +-- | Read control commands from `appJobCtl` and address them as they come in +-- +-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders. +-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ... +handleJobs recvChans foundation@UniWorX{..} = do + jobCrontab <- liftIO $ newTVarIO HashMap.empty + jobConfirm <- liftIO $ newTVarIO HashMap.empty + + forM_ (zip [1..] recvChans) $ \(n, chan) -> + let + logStart = $logDebugS ("Jobs #" <> tshow n) "Starting" + logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping" + doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n + in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan) + + -- Start cron operation + void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread) + liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ + writeJobCtlBlock JobCtlDetermineCrontab + + +execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) () +-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have +-- seen, wait for the time of the next job and fire it +execCrontab = flip evalStateT HashMap.empty . forever $ do + mapStateT (liftHandlerT . runDB . setSerializable) $ do + let + merge (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) + | otherwise = lift $ delete leId + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge + + now <- liftIO getCurrentTime + (currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do + crontab <- liftBase . readTVar =<< asks jobCrontab + State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab + prevExec <- State.get + case earliestJob prevExec crontab now of + Nothing -> liftBase retry + Just (_, MatchNone) -> liftBase retry + Just x -> return (crontab, x) + + let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do + newCrontab <- lift . lift . hoist lift $ determineCrontab' + if + | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab + -> do + now <- liftIO $ getCurrentTime + instanceID <- getsYesod appInstanceID + State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl + case jobCtl of + JobCtlQueue job -> do + lift . lift $ upsertBy + (UniqueCronLastExec $ toJSON job) + CronLastExec + { cronLastExecJob = toJSON job + , cronLastExecTime = now + , cronLastExecInstance = instanceID + } + [ CronLastExecTime =. now ] + lift . lift $ queueDBJob job + other -> writeJobCtl other + | otherwise + -> lift . mapReaderT (liftIO . atomically) $ + lift . flip writeTVar newCrontab =<< asks jobCrontab + + case nextMatch of + MatchAsap -> doJob + MatchNone -> return () + MatchAt nextTime -> do + JobContext{jobCrontab} <- ask + nextTime' <- applyJitter jobCtl nextTime + $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|] + logFunc <- askLoggerIO + whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime') + doJob + where + acc :: NominalDiffTime + acc = 1e-3 + + applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime + applyJitter seed t = do + appInstance <- getsYesod appInstanceID + let + halfRange = truncate $ 0.5 / acc + diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed) + return $ addUTCTime diff t + + earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) + earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab + where + go (jobCtl, cron) mbPrev + | Just (_, t') <- mbPrev + , t' < t + = mbPrev + | otherwise + = Just (jobCtl, t) + where + t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron + + waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool + waitUntil crontabTV crontab nextTime = runResourceT $ do + diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime + let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc + waitTime' + | diffT < acc = "Done" + | otherwise = tshow (realToFrac waitTime :: NominalDiffTime) + $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|] + if + | diffT < acc -> return True + | otherwise -> do + retVar <- liftIO newEmptyTMVarIO + void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread) + let + awaitDelayThread = False <$ takeTMVar retVar + awaitCrontabChange = do + crontab' <- readTVar crontabTV + True <$ guard (crontab /= crontab') + crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread + bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged + + +handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) () +handleJobs' wNum = C.mapM_ $ \jctl -> do + $logDebugS logIdent $ tshow jctl + resVars <- mapReaderT (liftIO . atomically) $ + HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm) + res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl + sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars) + case res of + Just err + | not sentRes -> $logErrorS logIdent $ tshow err + _other -> return () + where + logIdent = "Jobs #" <> tshow wNum + + handleQueueException :: MonadLogger m => JobQueueException -> m () + handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j + handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) + handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) + + handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform) + handleCmd (JobCtlQueue job) = lift $ queueJob' job + handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do + content <- case fromJSON queuedJobContent of + Aeson.Success c -> return c + Aeson.Error t -> do + $logErrorS logIdent $ "Aeson decoding error: " <> pack t + throwM $ JInvalid jId j + + $logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content + + performJob content + + -- `performJob` is expected to throw an exception if it detects that the job was not done + runDB $ delete jId + handleCmd JobCtlDetermineCrontab = do + newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab' + -- $logDebugS logIdent $ tshow newCTab + mapReaderT (liftIO . atomically) $ + lift . flip writeTVar newCTab =<< asks jobCrontab + +jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a +jLocked jId act = do + hasLock <- liftIO $ newTVarIO False + + let + lock = runDB . setSerializable $ do + qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId + instanceID <- getsYesod appInstanceID + threshold <- getsYesod $ appJobStaleThreshold . appSettings + now <- liftIO getCurrentTime + hadStale <- maybeT (return False) $ do + lockTime <- MaybeT $ return queuedJobLockTime + lockInstance <- MaybeT $ return queuedJobLockInstance + if + | lockInstance == instanceID + , diffUTCTime now lockTime >= threshold + -> return True + | otherwise + -> throwM $ JLocked jId lockInstance lockTime + when hadStale . + $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj + val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID + , QueuedJobLockTime =. Just now + ] + liftIO . atomically $ writeTVar hasLock True + return val + + unlock = whenM (liftIO . atomically $ readTVar hasLock) $ + runDB . setSerializable $ + update jId [ QueuedJobLockInstance =. Nothing + , QueuedJobLockTime =. Nothing + ] + + bracket lock (const unlock) act + + +pruneLastExecs :: Crontab JobCtl -> DB () +pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab + where + ensureCrontab (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + , HashMap.member (JobCtlQueue job) crontab + = return () + | otherwise = delete leId + +determineCrontab' :: DB (Crontab JobCtl) +determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab + + +performJob :: Job -> HandlerT UniWorX IO () +performJob = $(dispatchTH ''Job) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs new file mode 100644 index 000000000..ad0fecc21 --- /dev/null +++ b/src/Jobs/Crontab.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , FlexibleContexts + , MultiWayIf + , NamedFieldPuns + , TypeFamilies + #-} + +module Jobs.Crontab + ( determineCrontab + ) where + +import Import + +import qualified Data.HashMap.Strict as HashMap +import Jobs.Types + +import Data.Maybe (fromJust) +import qualified Data.Map as Map +import Data.Semigroup (Max(..)) + +import Data.Time +import Data.Time.Zones + +import Control.Monad.Trans.Writer (execWriterT) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import qualified Data.Conduit.List as C + + +determineCrontab :: DB (Crontab JobCtl) +-- ^ Extract all future jobs from the database (sheet deadlines, ...) +determineCrontab = execWriterT $ do + AppSettings{..} <- getsYesod appSettings + + case appJobFlushInterval of + Just interval -> tell $ HashMap.singleton + JobCtlFlush + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = interval + , cronNotAfter = Right CronNotScheduled + } + Nothing -> return () + + tell $ HashMap.singleton + JobCtlDetermineCrontab + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = appJobCronInterval + , cronNotAfter = Right CronNotScheduled + } + + let + sheetJobs (Entity nSheet Sheet{..}) = do + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom + , cronRepeat = CronRepeatNever + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo + } + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..}) + Cron + { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo + , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo + } + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..}) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left appNotificationExpiration + } + + sheetSubmissions <- lift $ collateSubmissions <$> + selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] [] + tell $ flip Map.foldMapWithKey sheetSubmissions $ + \nUser (Max mbTime) -> if + | Just time <- mbTime -> HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } ) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time + , cronRepeat = CronRepeatNever + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left appNotificationExpiration + } + | otherwise -> mempty + + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs + +-- | Partial function: Submission must not have Nothing at ratingBy +collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime)) +collateSubmissions = Map.fromListWith (<>) . fmap procCorrector + where + procCorrector :: Entity Submission -> (UserId , (Max (Maybe UTCTime))) + procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal + <*> Max . submissionRatingAssigned . entityVal + diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs new file mode 100644 index 000000000..ba466d700 --- /dev/null +++ b/src/Jobs/Handler/HelpRequest.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , RecordWildCards + , OverloadedStrings + #-} + +module Jobs.Handler.HelpRequest + ( dispatchJobHelpRequest + ) where + +import Import hiding ((.=)) + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +import Handler.Utils.DateTime + +import Utils.Lens + +import Data.Bitraversable + + +dispatchJobHelpRequest :: Either (Maybe Email) UserId + -> UTCTime + -> Text -- ^ Help Request + -> Maybe Text -- ^ Referer + -> Handler () +dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do + supportAddress <- getsYesod $ appMailSupport . appSettings + userInfo <- bitraverse return (runDB . getEntity) jSender + let userAddress = either (fmap $ Address Nothing) + (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) + userInfo + mailT def $ do + _mailTo .= [supportAddress] + whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress + setSubjectI MsgMailSubjectSupport + setDate jRequestTime + rtime <- formatTimeMail SelFormatDateTime jRequestTime + addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs new file mode 100644 index 000000000..024d57682 --- /dev/null +++ b/src/Jobs/Handler/QueueNotification.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + #-} + +module Jobs.Handler.QueueNotification + ( dispatchJobQueueNotification + ) where + +import Import + +import Jobs.Types + +import qualified Database.Esqueleto as E +import Utils.Sql +import Jobs.Queue + + +dispatchJobQueueNotification :: Notification -> Handler () +dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do + candidates <- hoist lift $ determineNotificationCandidates jNotification + nClass <- hoist lift $ classifyNotification jNotification + mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do + Entity uid User{userNotificationSettings} <- candidates + guard $ notificationAllowed userNotificationSettings nClass + return uid + + +determineNotificationCandidates :: Notification -> DB [Entity User] +determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do + E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission + return user +determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse + E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user +determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse + E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user +determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do + E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse + E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId + E.where_ $ sheet E.^. SheetId E.==. E.val nSheet + return user +determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] [] + +classifyNotification :: Notification -> DB NotificationTrigger +classifyNotification NotificationSubmissionRated{..} = do + Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission + return $ case sheetType of + NotGraded -> NTSubmissionRated + _other -> NTSubmissionRatedGraded +classifyNotification NotificationSheetActive{} = return NTSheetActive +classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive +classifyNotification NotificationSheetInactive{} = return NTSheetInactive +classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned + + diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs new file mode 100644 index 000000000..a554bcfa8 --- /dev/null +++ b/src/Jobs/Handler/SendNotification.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + #-} + +module Jobs.Handler.SendNotification + ( dispatchJobSendNotification + ) where + +import Import + +import Jobs.TH +import Jobs.Types + + +import Jobs.Handler.SendNotification.SubmissionRated +import Jobs.Handler.SendNotification.SheetActive +import Jobs.Handler.SendNotification.SheetInactive +import Jobs.Handler.SendNotification.CorrectionsAssigned + + +dispatchJobSendNotification :: UserId -> Notification -> Handler () +dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs new file mode 100644 index 000000000..6b7ed47d8 --- /dev/null +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.CorrectionsAssigned + ( dispatchNotificationCorrectionsAssigned + ) where + +import Import + +import Utils.Lens +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler () +dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do + (Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + nbrSubs <- count [ SubmissionSheet ==. nSheet + , SubmissionRatingBy ==. Just nUser + , SubmissionRatingTime ==. Nothing + ] + return (course, sheet, nbrSubs) + when (nbrSubs > 0) . userMailT jRecipient $ do + setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") + providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs new file mode 100644 index 000000000..aaedcb7a6 --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.SheetActive + ( dispatchNotificationSheetActive + ) where + +import Import + +import Utils.Lens +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +dispatchNotificationSheetActive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") + providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs new file mode 100644 index 000000000..6873d2b28 --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.SheetInactive + ( dispatchNotificationSheetSoonInactive + , dispatchNotificationSheetInactive + ) where + +import Import + +import Utils.Lens +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.CaseInsensitive as CI + +dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") + providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + +dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler () +dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do + (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do + sheet <- getJust nSheet + course <- belongsToJust sheetCourse sheet + return (course, sheet) + setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName + + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + addAlternatives $ do + let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") + providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + \ No newline at end of file diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs new file mode 100644 index 000000000..885dc8bfe --- /dev/null +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , TemplateHaskell + , OverloadedStrings + #-} + +module Jobs.Handler.SendNotification.SubmissionRated + ( dispatchNotificationSubmissionRated + ) where + +import Import + +import Utils.Lens +import Handler.Utils.DateTime +import Handler.Utils.Mail + +import Text.Hamlet +import qualified Data.Aeson as Aeson +import qualified Data.CaseInsensitive as CI + +dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler () +dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do + (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do + submission@Submission{submissionRatingBy} <- getJust nSubmission + sheet <- belongsToJust submissionSheet submission + course <- belongsToJust sheetCourse sheet + corrector <- traverse getJust submissionRatingBy + return (course, sheet, submission, corrector) + setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand + + csid <- encrypt nSubmission + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime + let tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + -- TODO: provide convienience template-haskell for `addAlternatives` + addAlternatives $ do + provideAlternative $ Aeson.object + [ "submission" Aeson..= ciphertext csid + , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints) + , "submission-rating-comment" Aeson..= submissionRatingComment + , "submission-rating-time" Aeson..= submissionRatingTime + , "submission-rating-by" Aeson..= (userDisplayName <$> corrector) + , "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType) + , "sheet-name" Aeson..= sheetName + , "sheet-type" Aeson..= sheetType + , "course-name" Aeson..= courseName + , "course-shorthand" Aeson..= courseShorthand + , "course-term" Aeson..= courseTerm + , "course-school" Aeson..= courseSchool + ] + -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements + let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") + providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs new file mode 100644 index 000000000..4b2865fdd --- /dev/null +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , NamedFieldPuns + , QuasiQuotes + #-} + +module Jobs.Handler.SendTestEmail + ( dispatchJobSendTestEmail + ) where + +import Import hiding ((.=)) + +import Handler.Utils.DateTime + +import Text.Shakespeare.Text + +import Utils.Lens + +dispatchJobSendTestEmail :: Email -> MailContext -> Handler () +dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do + _mailTo .= [Address Nothing jEmail] + setSubjectI MsgMailTestSubject + now <- liftIO getCurrentTime + nDT <- formatTimeMail SelFormatDateTime now + nD <- formatTimeMail SelFormatDate now + nT <- formatTimeMail SelFormatTime now + addPart $ \(MsgRenderer mr) -> ([text| + #{mr MsgMailTestContent} + + #{mr MsgMailTestDateTime} + * #{nDT} + * #{nD} + * #{nT} + |] :: TextUrl (Route UniWorX)) diff --git a/src/Jobs/Handler/SetLogSettings.hs b/src/Jobs/Handler/SetLogSettings.hs new file mode 100644 index 000000000..01c8d618f --- /dev/null +++ b/src/Jobs/Handler/SetLogSettings.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude + #-} + +module Jobs.Handler.SetLogSettings + ( dispatchJobSetLogSettings + ) where + +import Import + +dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler () +dispatchJobSetLogSettings jInstance jLogSettings = do + instanceId <- getsYesod appInstanceID + unless (instanceId == jInstance) $ fail "Incorrect instance" + lSettings <- getsYesod appLogSettings + atomically $ writeTVar lSettings jLogSettings diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs new file mode 100644 index 000000000..d72734aeb --- /dev/null +++ b/src/Jobs/Queue.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NoImplicitPrelude + , TypeFamilies + #-} + +module Jobs.Queue + ( writeJobCtl, writeJobCtlBlock + , queueJob, queueJob' + , YesodJobDB + , runDBJobs, queueDBJob + ) where + +import Import + +import Utils.Sql +import Jobs.Types + +import Control.Monad.Trans.Writer (WriterT, runWriterT) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT) + +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.HashMap.Strict as HashMap + +import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform) + + +writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () +writeJobCtl cmd = do + tid <- liftIO myThreadId + chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl + liftIO . atomically $ writeTMChan chan cmd + +writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () +writeJobCtlBlock cmd = do + getResVar <- asks jobConfirm + resVar <- liftIO . atomically $ do + var <- newEmptyTMVar + modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) + return var + lift $ writeJobCtl cmd + let + removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd + mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar + maybe (return ()) throwM mExc + +queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId +queueJobUnsafe job = do + now <- liftIO getCurrentTime + self <- getsYesod appInstanceID + insert QueuedJob + { queuedJobContent = toJSON job + , queuedJobCreationInstance = self + , queuedJobCreationTime = now + , queuedJobLockInstance = Nothing + , queuedJobLockTime = Nothing + } + -- We should not immediately notify a worker; instead wait for the transaction to finish first + -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) + -- return jId + +queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId +queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe + +queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m () +-- ^ `queueJob` followed by `JobCtlPerform` +queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform + +type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO)) + +queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) () +queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton + +runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +runDBJobs act = do + (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act + forM_ jIds $ writeJobCtl . JobCtlPerform + return ret + + + diff --git a/src/Jobs/TH.hs b/src/Jobs/TH.hs new file mode 100644 index 000000000..47e69f62d --- /dev/null +++ b/src/Jobs/TH.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , QuasiQuotes + , RecordWildCards + #-} + +module Jobs.TH + ( dispatchTH + ) where + +import ClassyPrelude + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +import Data.List (foldl) + + +dispatchTH :: Name -- ^ Datatype to pattern match + -> ExpQ +dispatchTH dType = do + DatatypeInfo{..} <- reifyDatatype dType + let + matches = map mkMatch datatypeCons + mkMatch ConstructorInfo{..} = do + pats <- forM constructorFields $ \_ -> newName "x" + let fName = mkName $ "dispatch" <> nameBase constructorName + match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) [] + lamCaseE matches diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs new file mode 100644 index 000000000..63b947a69 --- /dev/null +++ b/src/Jobs/Types.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TemplateHaskell + , NoImplicitPrelude + , DeriveGeneric + , DeriveDataTypeable + #-} + +module Jobs.Types + ( Job(..), Notification(..) + , JobCtl(..) + , JobContext(..) + ) where + +import Import.NoFoundation + +import Data.Aeson (defaultOptions, Options(..), SumEncoding(..)) +import Data.Aeson.TH (deriveJSON) + +import Data.List.NonEmpty (NonEmpty) + + +data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } + | JobQueueNotification { jNotification :: Notification } + | JobHelpRequest { jSender :: Either (Maybe Email) UserId + , jRequestTime :: UTCTime + , jHelpRequest :: Text, jReferer :: Maybe Text } + | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } + deriving (Eq, Ord, Show, Read, Generic, Typeable) +data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } + | NotificationSheetActive { nSheet :: SheetId } + | NotificationSheetSoonInactive { nSheet :: SheetId } + | NotificationSheetInactive { nSheet :: SheetId } + | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance Hashable Job +instance Hashable Notification + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , tagSingleConstructors = True + , sumEncoding = TaggedObject "job" "data" + } ''Job + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , tagSingleConstructors = True + , sumEncoding = TaggedObject "notification" "data" + } ''Notification + + +data JobCtl = JobCtlFlush + | JobCtlPerform QueuedJobId + | JobCtlDetermineCrontab + | JobCtlQueue Job + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Hashable JobCtl + + +data JobContext = JobContext + { jobCrontab :: TVar (Crontab JobCtl) + , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException)))) + } diff --git a/src/Mail.hs b/src/Mail.hs new file mode 100644 index 000000000..c812bc583 --- /dev/null +++ b/src/Mail.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE NoImplicitPrelude + , GeneralizedNewtypeDeriving + , DerivingStrategies + , FlexibleInstances + , MultiParamTypeClasses + , UndecidableInstances + , DeriveGeneric + , TemplateHaskell + , OverloadedStrings + , RecordWildCards + , FlexibleContexts + , TypeFamilies + , ViewPatterns + , NamedFieldPuns + , MultiWayIf + , QuasiQuotes + , RankNTypes + , ScopedTypeVariables + , DeriveDataTypeable + #-} + +module Mail + ( -- * Structured MIME emails + module Network.Mail.Mime + -- * MailT + , MailT, defMailT + , MailSmtpData(..), MailContext(..), MailLanguages(..) + , MonadMail(..) + , getMailMessageRender, getMailMsgRenderer + -- * YesodMail + , VerpMode(..) + , YesodMail(..) + , MailException(..) + -- * Monadically constructing Mail + , PrioritisedAlternatives + , ToMailPart(..) + , addAlternatives, provideAlternative, providePreferredAlternative + , addPart + , MonadHeader(..) + , MailHeader + , MailObjectId + , replaceMailHeader, addMailHeader, removeMailHeader + , replaceMailHeaderI, addMailHeaderI + , setSubjectI, setMailObjectId, setMailObjectId' + , setDate, setDateCurrent + , setMailSmtpData + , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts + , _partType, _partEncoding, _partFilename, _partHeaders, _partContent + ) where + +import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender) +import qualified ClassyPrelude.Yesod as Yesod (getMessageRender) + +import Network.Mail.Mime hiding (addPart, addAttachment) +import qualified Network.Mail.Mime as Mime (addPart) + +import Data.Monoid (Last(..)) +import Control.Monad.Trans.RWS (RWST(..), execRWST) +import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT) +import Control.Monad.Trans.Writer (execWriter, Writer) +import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify) +import Control.Monad.Fail + +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Data.Data (Data) + +import Data.Set (Set) +import qualified Data.Set as Set + +import qualified Data.Text as Text + +import qualified Data.Foldable as Foldable + +import Data.Hashable + +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LTB +import qualified Data.ByteString.Lazy as LBS + +import Utils (MsgRendererS(..)) +import Utils.Lens.TH +import Control.Lens + +import Text.Blaze.Renderer.Utf8 + +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID +import Data.UUID.Cryptographic.ImplicitNamespace + +import Data.Binary (Binary) + +import GHC.TypeLits (KnownSymbol) + +import Network.BSD (getHostName) + +import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime) +import Data.Time.LocalTime (ZonedTime(..)) +import Data.Time.Format + +import Network.HaskellNet.SMTP (SMTPConnection) +import qualified Network.HaskellNet.SMTP as SMTP + +import qualified Text.Hamlet as Hamlet (Translate) +import qualified Text.Shakespeare as Shakespeare (RenderUrl) + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson +import Data.Aeson (Options(..)) +import Data.Aeson.TH +import Utils (MsgRendererS(..)) +import Utils.PathPiece (splitCamel) +import Utils.DateTime + +import Data.Universe.Instances.Reverse () +import Data.Universe.Instances.Reverse.JSON () +import Data.Universe.Instances.Reverse.Hashable () + +makeLenses_ ''Mail +makeLenses_ ''Part + + +newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a } + deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus + , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b + , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext + ) + +instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where + type MonadCryptoKey (MailT m) = CryptoIDKey + cryptoIDKey f = lift (cryptoIDKey return) >>= f + +data MailSmtpData = MailSmtpData + { smtpEnvelopeFrom :: Last Text + , smtpRecipients :: Set Text + } deriving (Eq, Ord, Show, Read, Generic) + +instance Monoid (MailSmtpData) where + mempty = memptydefault + mappend = mappenddefault + +newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + deriving newtype (FromJSON, ToJSON) + +instance Default MailLanguages where + def = MailLanguages [] + +instance Hashable MailLanguages + +data MailContext = MailContext + { mcLanguages :: MailLanguages + , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''MailContext + +instance Hashable MailContext +instance Default MailContext where + def = MailContext { mcLanguages = def + , mcDateTimeFormat = def + } + +makeLenses_ ''MailContext + +class (MonadHandler m, MonadState Mail m) => MonadMail m where + askMailLanguages :: m MailLanguages + askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat + tellMailSmtpData :: MailSmtpData -> m () + +instance MonadHandler m => MonadMail (MailT m) where + askMailLanguages = view _mcLanguages + askMailDateTimeFormat = (view _mcDateTimeFormat ??) + tellMailSmtpData = tell + +data VerpMode = VerpNone + | Verp { verpSeparator, verpAtReplacement :: Char } + deriving (Eq, Show, Read) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = UntaggedValue + } ''VerpMode + +getMailMessageRender :: ( MonadMail m + , HandlerSite m ~ site + , RenderMessage site msg + ) => m (msg -> Text) +getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages) + +getMailMsgRenderer :: forall site m. + ( MonadMail m + , HandlerSite m ~ site + ) => m (MsgRendererS site) +getMailMsgRenderer = do + mr <- getMailMessageRender + return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text) + + +data MailException = MailNotAvailable + | MailNoSenderSpecified + | MailNoRecipientsSpecified + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Exception MailException + + +class Yesod site => YesodMail site where + defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address + defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName + + mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text + mailObjectIdDomain = pack <$> liftIO getHostName + + mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ + mailDateTZ = return utcTZ + + mailSmtp :: ( MonadHandler m + , HandlerSite m ~ site + , MonadBaseControl IO m + ) => (SMTPConnection -> m a) -> m a + mailSmtp _ = throwM MailNotAvailable + + mailVerp :: ( MonadHandler m + , HandlerSite m ~ site + ) => m VerpMode + mailVerp = return VerpNone + + mailT :: ( MonadHandler m + , HandlerSite m ~ site + , MonadBaseControl IO m + , MonadLogger m + ) => MailContext -> MailT m a -> m a + mailT = defMailT + + defaultMailLayout :: ( MonadHandler m + , HandlerSite m ~ site + ) => WidgetT site IO () -> m Html + defaultMailLayout wgt = do + PageContent{..} <- liftHandlerT $ widgetToPageContent wgt + msgs <- getMessages + withUrlRenderer [hamlet| + $newline never + $doctype 5 + + + #{pageTitle} + ^{pageHead} + <body> + $forall (status, msg) <- msgs + <p class="message #{status}">#{msg} + ^{pageBody} + |] + +defMailT :: ( MonadHandler m + , YesodMail (HandlerSite m) + , MonadBaseControl IO m + , MonadLogger m + ) => MailContext + -> MailT m a + -> m a +defMailT ls (MailT mail) = do + fromAddress <- defaultFromAddress + (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress) + mail' <- liftIO $ LBS.toStrict <$> renderMail' mail + $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail' + ret <$ case smtpData of + MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified + MailSmtpData{ smtpRecipients } + | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified + MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath)) + , smtpRecipients = (map unpack . toList -> recipients) + } -> mailSmtp $ \conn -> do + $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData + liftIO $ SMTP.sendMail + returnPath + recipients + mail' + conn + + +data PrioritisedAlternatives m = PrioritisedAlternatives + { preferredAlternative :: Last (m Part) + , otherAlternatives :: Seq (m Part) + } deriving (Generic) + +instance Monoid (PrioritisedAlternatives m) where + mempty = memptydefault + mappend = mappenddefault + +class YesodMail site => ToMailPart site a where + type MailPartReturn site a :: * + type MailPartReturn site a = () + toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a) + +instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where + type MailPartReturn site (StateT Part (HandlerT site IO) a) = a + toMailPart = mapStateT liftHandlerT + +instance YesodMail site => ToMailPart site LT.Text where + toMailPart text = do + _partType .= "text/plain; charset=utf-8" + _partEncoding .= QuotedPrintableText + _partContent .= encodeUtf8 text + +instance YesodMail site => ToMailPart site Text where + toMailPart = toMailPart . LT.fromStrict + +instance YesodMail site => ToMailPart site LTB.Builder where + toMailPart = toMailPart . LTB.toLazyText + +instance YesodMail site => ToMailPart site Html where + toMailPart html = do + _partType .= "text/html; charset=utf-8" + _partEncoding .= QuotedPrintableText + _partContent .= renderMarkup html + +instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where + type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a + toMailPart act = do + mr <- lift getMailMessageRender + toMailPart $ act (toHtml . mr) + +instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where + type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a + toMailPart act = do + mr <- lift getMailMsgRenderer + toMailPart $ act mr + +instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where + type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a + toMailPart act = do + ur <- getUrlRenderParams + toMailPart $ act ur + +instance YesodMail site => ToMailPart site Aeson.Value where + toMailPart val = do + _partType .= "application/json; charset=utf-8" + _partEncoding .= QuotedPrintableText + _partContent .= Aeson.encodePretty val + + +addAlternatives :: (MonadMail m) + => Writer (PrioritisedAlternatives m) () + -> m () +addAlternatives provided = do + let PrioritisedAlternatives{..} = execWriter provided + alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives + modify $ Mime.addPart alternatives + +provideAlternative, providePreferredAlternative + :: (MonadMail m, HandlerSite m ~ site, ToMailPart site a) + => a + -> Writer (PrioritisedAlternatives m) () +provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart } +providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart } + +addPart :: ( MonadMail m + , HandlerSite m ~ site + , ToMailPart site a + ) => a -> m (MailPartReturn site a) +addPart part = do + (ret, part') <- runStateT (toMailPart part) initialPart + modify . Mime.addPart $ pure part' + return ret + +initialPart :: Part +initialPart = Part + { partType = "text/plain" + , partEncoding = None + , partFilename = Nothing + , partHeaders = [] + , partContent = mempty + } + + +class MonadHandler m => MonadHeader m where + modifyHeaders :: (Headers -> Headers) -> m () + objectIdHeader :: m MailHeader + +instance MonadHandler m => MonadHeader (MailT m) where + modifyHeaders f = MailT . modify $ over _mailHeaders f + objectIdHeader = return "Message-ID" + +instance MonadHandler m => MonadHeader (StateT Part m) where + modifyHeaders f = _partHeaders %= f + objectIdHeader = return "Content-ID" + + +type MailHeader = ByteString +type MailObjectId = Text + + +replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m () +replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC + +addMailHeader :: MonadHeader m => MailHeader -> Text -> m () +addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c) + +removeMailHeader :: MonadHeader m => MailHeader -> m () +removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders + + +replaceMailHeaderI :: ( RenderMessage site msg + , MonadMail m + , HandlerSite m ~ site + , MonadHeader m + ) => MailHeader -> msg -> m () +replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg + +addMailHeaderI :: ( RenderMessage site msg + , MonadMail m + , HandlerSite m ~ site + , MonadHeader m + ) => MailHeader -> msg -> m () +addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg) + + +setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m () +setSubjectI = replaceMailHeaderI "Subject" + +setMailObjectUUID :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => UUID -> m MailObjectId +setMailObjectUUID uuid = do + domain <- mailObjectIdDomain + oidHeader <- objectIdHeader + let objectId = UUID.toText uuid <> "@" <> domain + replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">" + return objectId + +setMailObjectId :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => m MailObjectId +setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom + +setMailObjectId' :: ( MonadHeader m + , YesodMail (HandlerSite m) + , MonadCrypto m + , HasCryptoUUID plain m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol (CryptoIDNamespace UUID plain) + , Binary plain + ) => plain -> m MailObjectId +setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid + + +setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () +setDateCurrent = setDate =<< liftIO getCurrentTime + +setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m () +setDate time = do + tz <- mailDateTZ + let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time) + replaceMailHeader "Date" . Just $ pack timeStr + + +setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () +setMailSmtpData = do + Address _ from <- use _mailFrom + recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use + + tell $ mempty { smtpRecipients = recps } + + verpMode <- mailVerp + if + | Verp{..} <- verpMode + , [recp] <- Set.toList recps + -> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat + [ user + , Text.singleton verpSeparator + , Text.replace "@" (Text.singleton verpAtReplacement) recp + , domain + ] + in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp } + | otherwise + -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from } diff --git a/src/Model.hs b/src/Model.hs index f57f39a7c..76a543723 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -7,6 +7,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -14,6 +16,7 @@ module Model ( module Model , module Model.Types + , module Cron.Types ) where import ClassyPrelude.Yesod @@ -21,11 +24,16 @@ import Database.Persist.Quasi -- import Data.Time -- import Data.ByteString import Model.Types -import Data.Aeson.TH +import Cron.Types + +import Data.Aeson (Value) +import Data.Aeson.TH (deriveJSON, defaultOptions) import Data.CaseInsensitive (CI) import Data.CaseInsensitive.Instances () +import Utils.Message (MessageClass) + -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: @@ -35,7 +43,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) - + data PWEntry = PWEntry { pwUser :: User , pwHash :: Text @@ -43,4 +51,4 @@ data PWEntry = PWEntry $(deriveJSON defaultOptions ''PWEntry) submissionRatingDone :: Submission -> Bool -submissionRatingDone Submission{..} = isJust submissionRatingPoints +submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 54ec40156..bd6be6098 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"'; |] ) + , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] + , whenM (tableExists "user") $ do + [executeQQ| + ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null; + UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 4f406a148..b4d3a41c5 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -5,16 +5,25 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE MultiWayIf #-} {-- # LANGUAGE ExistentialQuantification #-} -- for DA type {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) -module Model.Types where +module Model.Types + ( module Model.Types + , module Numeric.Natural + , module Mail + , module Utils.DateTime + ) where import ClassyPrelude import Utils import Control.Lens +import Utils.Lens.TH import Data.Set (Set) import qualified Data.Set as Set @@ -26,6 +35,8 @@ import Data.Universe import Data.Universe.Helpers import Data.UUID.Types +import Data.Default + import Text.Read (readMaybe) import Database.Persist.TH hiding (derivePersistFieldJSON) @@ -40,20 +51,40 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lens as Text +import qualified Data.HashMap.Strict as HashMap + import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () import Yesod.Core.Dispatch (PathPiece(..)) -import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value()) +import Data.Aeson.Types (toJSONKeyText) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Typeable (Typeable) +import Data.Universe.Instances.Reverse () + import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Mail (MailLanguages(..)) +import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..)) + +import Numeric.Natural +import Data.Word.Word24 (Word24) +import Data.Bits +import Data.Ix +import Data.List (genericIndex, elemIndex) +import System.Random (Random(..)) +import Data.Data (Data) + +import Model.Types.Wordlist + instance PathPiece UUID where fromPathPiece = Data.UUID.Types.fromString . unpack @@ -93,8 +124,9 @@ fromPoints = round instance DisplayAble Points data SheetType - = Bonus { maxPoints :: Points } - | Normal { maxPoints :: Points } + = Bonus { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben + | Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben +-- | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift | Pass { maxPoints, passingPoints :: Points } | NotGraded deriving (Show, Read, Eq) @@ -108,6 +140,8 @@ instance DisplayAble SheetType where deriveJSON defaultOptions ''SheetType derivePersistFieldJSON ''SheetType +makeLenses_ ''SheetType + data SheetTypeSummary = SheetTypeSummary { sumBonusPoints :: Sum Points , sumNormalPoints :: Sum Points @@ -130,13 +164,15 @@ sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } data SheetGroup - = Arbitrary { maxParticipants :: Int } + = Arbitrary { maxParticipants :: Natural } | RegisteredGroups | NoGroups deriving (Show, Read, Eq) deriveJSON defaultOptions ''SheetGroup derivePersistFieldJSON ''SheetGroup +makeLenses_ ''SheetGroup + data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "SheetFileType" @@ -201,6 +237,16 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool } deriveJSON defaultOptions ''UploadMode derivePersistFieldJSON ''UploadMode +data SheetSubmissionMode = NoSubmissions + | CorrectorSubmissions + | UserSubmissions + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . splitCamel + } ''SheetSubmissionMode +derivePersistField "SheetSubmissionMode" + data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "ExamStatus" @@ -216,8 +262,6 @@ deriveJSON defaultOptions ''Load derivePersistFieldJSON ''Load - - instance Semigroup Load where (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') where @@ -332,7 +376,7 @@ instance PathPiece TermIdentifier where toPathPiece = termToText instance ToJSON TermIdentifier where - toJSON = String . termToText + toJSON = Aeson.String . termToText instance FromJSON TermIdentifier where parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText @@ -355,6 +399,16 @@ data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded) derivePersistField "StudyFieldType" +instance PersistField UUID where + toPersistValue = PersistDbSpecific . toASCIIBytes + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" + instance DisplayAble StudyFieldType data Theme @@ -391,12 +445,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName -newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } - deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString) - -data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime - deriving (Eq, Ord, Read, Show, Enum, Bounded) - data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded) @@ -429,14 +477,160 @@ deriveJSON defaultOptions derivePersistFieldJSON ''AuthenticationMode - + +derivePersistFieldJSON ''Value + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetSoonInactive + | NTSheetInactive + | NTCorrectionsAssigned + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetSoonInactive -> False + NTSheetInactive -> True + NTCorrectionsAssigned -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings + + +instance ToBackendKey SqlBackend record => Hashable (Key record) where + hashWithSalt s key = s `hashWithSalt` fromSqlKey key + + +derivePersistFieldJSON ''MailLanguages + + +newtype Pseudonym = Pseudonym Word24 + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix) + + +instance PersistField Pseudonym where + toPersistValue p = toPersistValue (fromIntegral p :: Word32) + fromPersistValue v = do + w <- fromPersistValue v :: Either Text Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> Left "Pseudonym out of range" + +instance PersistFieldSql Pseudonym where + sqlType _ = SqlInt32 + +instance Random Pseudonym where + randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen + random = randomR (minBound, maxBound) + +instance FromJSON Pseudonym where + parseJSON v@(Aeson.Number _) = do + w <- parseJSON v :: Aeson.Parser Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> fail "Pseudonym out auf range" + parseJSON (Aeson.String (map CI.mk . Text.words -> ws)) + = case preview pseudonymWords ws of + Just p -> return p + Nothing -> fail "Could not parse pseudonym" + parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do + ws' <- toList . map CI.mk <$> mapM parseJSON ws + case preview pseudonymWords ws' of + Just p -> return p + Nothing -> fail "Could not parse pseudonym words" + +instance ToJSON Pseudonym where + toJSON = toJSON . (review pseudonymWords :: Pseudonym -> [PseudonymWord]) + +pseudonymWordlist :: [PseudonymWord] +pseudonymWordlist = $(wordlist "config/wordlist.txt") + +pseudonymWords :: Prism' [PseudonymWord] Pseudonym +pseudonymWords = prism' pToWords pFromWords + where + pFromWords :: [PseudonymWord] -> Maybe Pseudonym + pFromWords [w1, w2] + | Just i1 <- elemIndex w1 pseudonymWordlist + , Just i2 <- elemIndex w2 pseudonymWordlist + , i1 <= maxWord, i2 <= maxWord + = Just $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + pFromWords _ = Nothing + + pToWords :: Pseudonym -> [PseudonymWord] + pToWords (Pseudonym p) + = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord + , genericIndex pseudonymWordlist $ p .&. maxWord + ] + + maxWord :: Num a => a + maxWord = 0b111111111111 + +pseudonymText :: Prism' Text Pseudonym +pseudonymText = iso tFromWords tToWords . pseudonymWords + where + tFromWords :: Text -> [PseudonymWord] + tFromWords = map CI.mk . Text.words + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + + -- Type synonyms +type PseudonymWord = CI Text + +type Email = Text + type SchoolName = CI Text type SchoolShorthand = CI Text type CourseName = CI Text type CourseShorthand = CI Text type SheetName = CI Text -type UserEmail = CI Text +type UserEmail = CI Email type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString +type InstanceId = UUID diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs index 655c95294..dc5a5eec6 100644 --- a/src/Model/Types/JSON.hs +++ b/src/Model/Types/JSON.hs @@ -50,7 +50,7 @@ derivePersistFieldJSON n = do ] , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t) [ funD (mkName "sqlType") - [ clause [wildP] (normalB [e|SqlOther "json"|]) [] + [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) [] ] ] ] diff --git a/src/Model/Types/Wordlist.hs b/src/Model/Types/Wordlist.hs new file mode 100644 index 000000000..d4bab9e8c --- /dev/null +++ b/src/Model/Types/Wordlist.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude + , TemplateHaskell + , ViewPatterns + , OverloadedStrings + #-} + +module Model.Types.Wordlist (wordlist) where + +import ClassyPrelude hiding (lift) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..)) + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import qualified Data.CaseInsensitive as CI + +wordlist :: FilePath -> ExpQ +wordlist file = do + qAddDependentFile file + wordlist' <- runIO $ filter ((||) <$> not . isComment <*> isWord) . Text.lines <$> Text.readFile file + listE $ map (\(Text.unpack -> word) -> [e|CI.mk $ Text.pack $(lift word)|]) wordlist' + +isWord :: Text -> Bool +isWord t + | [w] <- Text.words t + , w == t + = True + | otherwise + = False + +isComment :: Text -> Bool +isComment line = or + [ commentSymbol `Text.isPrefixOf` Text.stripStart line + , Text.null $ Text.strip line + ] + where + commentSymbol = "#" diff --git a/src/Settings.hs b/src/Settings.hs index 4649c76f4..c246311a7 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. @@ -15,7 +19,7 @@ module Settings where import ClassyPrelude.Yesod import qualified Control.Exception as Exception import Data.Aeson (Result (..), fromJSON, withObject, - (.!=), (.:?)) + (.!=), (.:?), withScientific) import qualified Data.Aeson.Types as Aeson import Data.Aeson.TH import Data.FileEmbed (embedFile) @@ -29,6 +33,12 @@ import Yesod.Default.Util (WidgetFileSettings, widgetFileReload) import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Data.Time (NominalDiffTime) + +import Data.Scientific (toBoundedInteger) +import Data.Word (Word16) + +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap @@ -39,6 +49,13 @@ import Control.Lens import Data.Maybe (fromJust) import qualified Data.Char as Char +import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) +import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) + +import Network.Mail.Mime (Address) + +import Mail (VerpMode) + import Model -- | Runtime settings to configure this application. These settings can be @@ -51,6 +68,8 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing the database. , appLdapConf :: Maybe LdapConf -- ^ Configuration settings for accessing the LDAP-directory + , appSmtpConf :: Maybe SmtpConf + -- ^ Configuration settings for accessing a SMTP Mailserver , appRoot :: Maybe Text -- ^ Base for all generated URLs. If @Nothing@, determined -- from the request headers. @@ -61,11 +80,20 @@ data AppSettings = AppSettings , appIpFromHeader :: Bool -- ^ Get the IP address from the header when logging. Useful when sitting -- behind a reverse proxy. + , appMailFrom :: Address + , appMailObjectDomain :: Text + , appMailVerp :: VerpMode + , appMailSupport :: Address + , appJobWorkers :: Int + , appJobFlushInterval :: Maybe NominalDiffTime + , appJobCronInterval :: NominalDiffTime + , appJobStaleThreshold :: NominalDiffTime + , appNotificationRateLimit :: NominalDiffTime + , appNotificationCollateDelay :: NominalDiffTime + , appNotificationExpiration :: NominalDiffTime + + , appInitialLogSettings :: LogSettings - , appDetailedRequestLogging :: Bool - -- ^ Use detailed request logging system - , appShouldLogAll :: Bool - -- ^ Should all log messages be displayed? , appReloadTemplates :: Bool -- ^ Use the reload version of templates , appMutableStatic :: Bool @@ -76,26 +104,38 @@ data AppSettings = AppSettings -- ^ Indicate if auth dummy login should be enabled. , appAllowDeprecated :: Bool -- ^ Indicate if deprecated routes are accessible for everyone - , appMinimumLogLevel :: LogLevel , appUserDefaults :: UserDefaultConf , appAuthPWHash :: PWHashConf , appCryptoIDKeyFile :: FilePath - } - + , appInstanceIDFile :: Maybe FilePath + } deriving (Show) + +data LogSettings = LogSettings + { logAll, logDetailed :: Bool + , logMinimumLevel :: LogLevel + } deriving (Show, Read, Generic, Eq, Ord) + +deriving instance Generic LogLevel +instance Hashable LogLevel +instance Hashable LogSettings + data UserDefaultConf = UserDefaultConf { userDefaultTheme :: Theme , userDefaultMaxFavourites :: Int , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool - } + } deriving (Show) data PWHashConf = PWHashConf { pwHashAlgorithm :: PWHashAlgorithm , pwHashStrength :: Int } +instance Show PWHashConf where + show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }" + instance FromJSON PWHashConf where parseJSON = withObject "PWHashConf" $ \o -> do pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text) @@ -113,8 +153,35 @@ data LdapConf = LdapConf , ldapBase :: Ldap.Dn , ldapScope :: Ldap.Scope , ldapTimeout :: Int32 - } + } deriving (Show) +data SmtpConf = SmtpConf + { smtpHost :: HaskellNet.HostName + , smtpPort :: HaskellNet.PortNumber + , smtpAuth :: Maybe SmtpAuthConf + , smtpSsl :: SmtpSslMode + , smtpPool :: ResourcePoolConf + } deriving (Show) + +data ResourcePoolConf = ResourcePoolConf + { poolStripes :: Int + , poolTimeout :: NominalDiffTime + , poolLimit :: Int + } deriving (Show) + +data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls + deriving (Show) + +data SmtpAuthConf = SmtpAuthConf + { smtpAuthType :: HaskellNet.AuthType + , smtpAuthUsername :: HaskellNet.UserName + , smtpAuthPassword :: HaskellNet.Password + } deriving (Show) + +deriveJSON defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . splitCamel + } ''LogSettings + deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel @@ -140,12 +207,64 @@ instance FromJSON LdapConf where return LdapConf{..} deriveFromJSON + defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''ResourcePoolConf + +deriveJSON defaultOptions { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level" , sumEncoding = UntaggedValue } ''LogLevel +instance FromJSON HaskellNet.PortNumber where + parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of + Just int -> return $ fromIntegral (int :: Word16) + Nothing -> fail "Expected whole number of plausible size to denote port" + +deriveFromJSON + defaultOptions + { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack + , allNullaryToStringTag = True + } + ''HaskellNet.AuthType + +instance FromJSON SmtpConf where + parseJSON = withObject "SmtpConf" $ \o -> do + smtpHost <- o .: "host" + smtpPort <- o .: "port" + smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth" + smtpSsl <- o .: "ssl" + smtpPool <- o .: "pool" + return SmtpConf{..} + +deriveFromJSON + defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + , allNullaryToStringTag = True + } + ''SmtpSslMode + +deriveFromJSON + defaultOptions + { fieldLabelModifier = let + nameMap "username" = "user" + nameMap "password" = "pass" + nameMap x = x + in nameMap . intercalate "-" . map toLower . drop 2 . splitCamel + } + ''SmtpAuthConf + +deriveFromJSON + defaultOptions + { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''Address + + + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -160,24 +279,38 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap" + appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" appRoot <- o .:? "approot" appHost <- fromString <$> o .: "host" appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" - appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev - appShouldLogAll <- o .:? "should-log-all" .!= defaultDev - appMinimumLogLevel <- o .: "minimum-log-level" + appMailFrom <- o .: "mail-from" + appMailObjectDomain <- o .: "mail-object-domain" + appMailVerp <- o .: "mail-verp" + appMailSupport <- o .: "mail-support" + + appJobWorkers <- o .: "job-workers" + appJobFlushInterval <- o .:? "job-flush-interval" + appJobCronInterval <- o .: "job-cron-interval" + appJobStaleThreshold <- o .: "job-stale-threshold" + appNotificationRateLimit <- o .: "notification-rate-limit" + appNotificationCollateDelay <- o .: "notification-collate-delay" + appNotificationExpiration <- o .: "notification-expiration" + appReloadTemplates <- o .:? "reload-templates" .!= defaultDev appMutableStatic <- o .:? "mutable-static" .!= defaultDev appSkipCombining <- o .:? "skip-combining" .!= defaultDev appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev + appInitialLogSettings <- o .: "log-settings" + appUserDefaults <- o .: "user-defaults" appAuthPWHash <- o .: "auth-pw-hash" appCryptoIDKeyFile <- o .: "cryptoid-keyfile" + appInstanceIDFile <- o .:? "instance-idfile" return AppSettings {..} diff --git a/src/Utils.hs b/src/Utils.hs index 08343ec80..17795138c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -21,11 +21,14 @@ import Data.Foldable as Fold hiding (length) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Lazy as LBS + import Utils.DB as Utils import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Message as Utils +import Utils.Lang as Utils import Text.Blaze (Markup, ToMarkup) @@ -53,6 +56,8 @@ import Instances.TH.Lift () import Text.Shakespeare.Text (st) +import qualified Data.Aeson as Aeson + ----------- @@ -312,6 +317,9 @@ maybeM dft act mb = mb >>= maybe dft act maybeT :: Monad m => m a -> MaybeT m a -> m a maybeT x m = runMaybeT m >>= maybe x return +maybeT_ :: Monad m => MaybeT m () -> m () +maybeT_ = void . runMaybeT + catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a catchIfMaybeT p act = catchIf p (lift act) (const mzero) @@ -434,3 +442,13 @@ orM = Fold.foldr or2M (return False) anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool anyM xs f = orM $ fmap f xs + +-------------- +-- Sessions -- +-------------- + +setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m () +setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val + +lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) +lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 380bb8b2a..69d230275 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -15,7 +15,7 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here - +-- ezero = E.val (0 :: Int64) emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 1b82dbe12..2d58788e3 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -2,7 +2,13 @@ , TemplateHaskell , QuasiQuotes , StandaloneDeriving + , DerivingStrategies , DeriveLift + , DeriveDataTypeable + , DeriveGeneric + , GeneralizedNewtypeDeriving + , OverloadedStrings + , FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,6 +16,8 @@ module Utils.DateTime ( timeLocaleMap , TimeLocale(..) , currentYear + , DateTimeFormat(..) + , SelDateTimeFormat(..) , module Data.Time.Zones , module Data.Time.Zones.TH ) where @@ -20,14 +28,29 @@ import System.Locale.Read import Data.Time (TimeZone(..), TimeLocale(..)) import Data.Time.Zones (TZ) import Data.Time.Zones.TH (includeSystemTZ) +import Data.Time.Clock.POSIX import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) import Instances.TH.Lift () +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Universe + +import Database.Persist.Sql (PersistField, PersistFieldSql) + +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson +import Data.Aeson.TH + +import Utils.PathPiece + deriving instance Lift TimeZone deriving instance Lift TimeLocale +instance Hashable UTCTime where + hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default @@ -63,3 +86,31 @@ currentYear = do now <- runIO getCurrentTime let (year, _, _) = toGregorian $ utctDay now [e|year|] + + +newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString) + +instance Hashable DateTimeFormat + +data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime + deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable) + +instance Universe SelDateTimeFormat +instance Finite SelDateTimeFormat +instance Hashable SelDateTimeFormat + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + } ''SelDateTimeFormat + +instance ToJSONKey SelDateTimeFormat where + toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt +instance FromJSONKey SelDateTimeFormat where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . String + +instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where + def SelFormatDateTime = "%c" + def SelFormatDate = "%F" + def SelFormatTime = "%T" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9a96781ef..12b92f430 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -9,11 +9,13 @@ , FlexibleContexts , NamedFieldPuns , ScopedTypeVariables + , MultiWayIf + , RecordWildCards #-} module Utils.Form where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (addMessage) import Settings import qualified Text.Blaze.Internal as Blaze (null) @@ -23,8 +25,18 @@ import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Map.Lazy ((!)) +import qualified Data.Map.Lazy as Map +import qualified Data.Set as Set + +import Data.List ((!!)) + import Web.PathPieces +import Data.UUID + +import Utils.Message + ------------------- -- Form Renderer -- ------------------- @@ -121,8 +133,8 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass) setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg } -addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a -addDatalist field mValues = field +addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a +addDatalist mValues field = field { fieldView = \fId fName fAttrs fRes fReq -> do listId <- newIdent values <- map toPathPiece . otoList <$> mValues @@ -135,12 +147,29 @@ addDatalist field mValues = field |] } +noValidate :: FieldSettings site -> FieldSettings site +noValidate = addAttr "formnovalidate" "" + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ -data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data FormIdentifier + = FIDcourse + | FIDsheet + | FIDsubmission + | FIDsettings + | FIDcorrectors + | FIDcorrectorTable + | FIDcorrection + | FIDcorrectionsUpload + | FIDcorrectionUpload + | FIDSystemMessageAdd + | FIDSystemMessageTable + | FIDSystemMessageModify + | FIDSystemMessageModifyTranslation UUID + | FIDSystemMessageAddTranslation + deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where fromPathPiece = readFromPathPiece @@ -195,7 +224,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype} fieldParse [] _ = return $ Right Nothing fieldParse [str] _ | str == toPathPiece btn = return $ Right $ Just btn - | otherwise = return $ Left "Wrong button value" -- SJ: Right Nothing?! + | otherwise = return $ Left "Wrong button value" fieldParse _ _ = return $ Left "Multiple button values" combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a] @@ -216,3 +245,45 @@ ciField :: ( Textual t , RenderMessage (HandlerSite m) FormMessage ) => Field m (CI t) ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField + +reorderField :: ( MonadHandler m + , HandlerSite m ~ site + , Eq a + , Show a + ) => HandlerT site IO (OptionList a) -> Field m [a] +-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result) +reorderField optList = Field{..} + where + fieldEnctype = UrlEncoded + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + OptionList{..} <- liftHandlerT optList + let + olNum = fromIntegral $ length olOptions + selOptions = Map.fromList $ do + i <- [1..olNum] + (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist + guard $ i == n + Just val <- return . olReadExternal $ pack extVal + return (i, val) + return $ if + | Map.keysSet selOptions == Set.fromList [1..olNum] + -> Right . Just $ map (selOptions !) [1..fromIntegral olNum] + | otherwise + -> Left "Not a valid permutation" + fieldView theId name attrs val isReq = do + OptionList{..} <- liftHandlerT optList + let + isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue + nums = map (id &&& withNum theId) [1..length olOptions] + withNum t n = tshow n <> "." <> t + $(widgetFile "widgets/permutation") + +--------------------- +-- Form evaluation -- +--------------------- + +formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m () +formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml +formResult FormMissing _ = return () +formResult (FormSuccess res) f = f res diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs new file mode 100644 index 000000000..6556cede3 --- /dev/null +++ b/src/Utils/Lang.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Utils.Lang where + +import ClassyPrelude.Yesod + +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) + +import qualified Data.Text as Text + + +selectLanguage :: MonadHandler m + => NonEmpty Lang -- ^ Available translations, first is default + -> m Lang +selectLanguage avL = selectLanguage' avL <$> languages + +selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default + -> [Lang] -- ^ Languages in preference order + -> Lang +selectLanguage' (defL :| _) [] = defL +selectLanguage' avL (l:ls) + | not $ null l + , Just l' <- find (== l) (NonEmpty.toList avL) + = l' + | not $ null l + , Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l + , found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL + = case found of + Just l' -> l' + Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls + | otherwise = selectLanguage' avL ls + +langMatches :: Lang -- ^ Needle + -> Lang -- ^ Haystack + -> Bool +langMatches = isPrefixOf `on` Text.splitOn "-" diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 438d21932..d0d61e68a 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,35 +1,62 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveLift #-} module Utils.Message ( MessageClass(..) - , addMessage, addMessageI + , addMessage, addMessageI, addMessageIHamlet, addMessageFile ) where -import Data.Text as Text (toLower) import Data.Universe import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece) +import Data.Aeson +import Data.Aeson.TH import qualified ClassyPrelude.Yesod (addMessage, addMessageI) -import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI) + +import Text.Hamlet + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift) data MessageClass = Error | Warning | Info | Success - deriving (Eq,Ord,Enum,Bounded,Show,Read) + deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) instance Universe MessageClass instance Finite MessageClass $( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 +deriveJSON defaultOptions + { constructorTagModifier = toLower + } ''MessageClass + instance PathPiece MessageClass where - toPathPiece = $(nullaryToPathPiece ''MessageClass [Text.toLower]) + toPathPiece = $(nullaryToPathPiece ''MessageClass [toLower]) fromPathPiece = finiteFromPathPiece +derivePersistField "MessageClass" + + addMessage :: MonadHandler m => MessageClass-> Html -> m () addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m () addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) + +addMessageIHamlet :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + , HandlerSite m ~ site + ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m () +addMessageIHamlet mc iHamlet = do + mr <- getMessageRender + ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) + +addMessageFile :: MessageClass -> FilePath -> ExpQ +addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs new file mode 100644 index 000000000..ef2d2c6ea --- /dev/null +++ b/src/Utils/Sql.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE FlexibleContexts #-} + +module Utils.Sql + ( setSerializable + ) where + +import ClassyPrelude.Yesod + +import Database.Persist.Sql + +import Database.PostgreSQL.Simple (sqlErrorHint) +import Control.Monad.Catch (handleIf) + +import Data.Time.Clock + +setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a +setSerializable act = setSerializable' (0 :: Integer) + where + act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act + + setSerializable' (min 10 -> logBackoff) = + handleIf + (\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e) + (\e -> do + let + delay :: NominalDiffTime + delay = 1e-3 * 2 ^ logBackoff + $logWarnS "Sql" $ tshow (delay, e) + transactionUndo + threadDelay . round $ delay * 1e6 + setSerializable' (succ logBackoff) + ) + act' + diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs new file mode 100644 index 000000000..80a7b7e00 --- /dev/null +++ b/src/Utils/SystemMessage.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + #-} + +module Utils.SystemMessage where + +import Import.NoFoundation + +import qualified Data.List.NonEmpty as NonEmpty +import Data.List (findIndex) + +import Control.Monad.Trans.Maybe (MaybeT(..)) + + +getSystemMessage :: MonadHandler m + => NonEmpty Lang -- ^ `appLanguages` + -> SystemMessageId + -> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation)) +getSystemMessage appLanguages smId = runMaybeT $ do + SystemMessage{..} <- MaybeT $ get smId + translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] [] + let + avL = NonEmpty.sortWith (\l -> NTop $ findIndex (langMatches l) $ NonEmpty.toList appLanguages) $ systemMessageDefaultLanguage :| map (systemMessageTranslationLanguage . entityVal) translations + lang <- selectLanguage avL + return (SystemMessage{..}, find (langMatches lang . systemMessageTranslationLanguage) $ map entityVal translations) diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 45bc84c7e..3f5579269 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -1,11 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} module Utils.TH where -- Common Utility Functions that require TemplateHaskell -- import Data.Char +import Prelude import Language.Haskell.TH -- import Control.Monad -- import Control.Monad.Trans.Class diff --git a/src/index.md b/src/index.md index a1c616b17..2fcfbeaa6 100644 --- a/src/index.md +++ b/src/index.md @@ -96,3 +96,50 @@ CryptoID Model.Migration : Manuelle Datenbank-Migration + +Jobs + : `handleJobs` worker thread handling background jobs + `JobQueueException` + +Jobs.Types + : `Job`, `Notification`, `JobCtl` Types of Jobs + +Cron.Types + : Datentypen zur Spezifikation von Intervallen zu denen Jobs ausgeführt werden + können: + + `Cron`, `CronMatch`, `CronAbsolute`, `CronRepeat`, `Crontab` + +Cron + : Seiteneffektfreie Berechnungen auf Typen aus `Cron.Types`: `nextCronMatch` + +Jobs.Queue + : Funktionen zum _anstoßen_ von Jobs und zur Kommunikation mit den + Worker-Threads + + `writeJobCtl` schickt Nachricht an einen pseudo-Zufälligen worker-thread der + lokalen Instanz + + `queueJob` und `queueJob'` schreiben neue Jobs in die Instanz-übergreifende + Job-Queue, `queueJob'` stößt außerdem einen lokalen worker-thread an sich + des Jobs anzunehmen + + `runDBJobs` ersetzt `runDB` und erlaubt `queueDBJob` zu + benutzen. `queueDBJob` schreibt einen Job in die Queue; am Ende stößt + `runDBJobs` lokale worker-threads für alle mit `queueDBJobs` eingetragenen + Jobs an. + +Jobs.TH + : Templatehaskell für den dispatch mechanismus für `Jobs` + +Jobs.Crontab + : Generiert `Crontab JobCtl` aus der Datenbank (sammelt alle in den Daten aus + der Datenbank impliziten Jobs (notifications zu bestimmten zeiten, + aufräumaktionen, ...) ein) + +Jobs.Handler.** + : Via `Jobs.TH` delegiert `Jobs` das Interpretieren und Ausführen eines Werts + aus `Jobs.Types` an einen dieser Handler + +Mail + : Monadically constructing MIME emails diff --git a/start.sh b/start.sh index da7e422d4..7f0a48c4e 100755 --- a/start.sh +++ b/start.sh @@ -3,6 +3,7 @@ unset HOST export DETAILED_LOGGING=true export LOG_ALL=true +export LOGLEVEL=info export DUMMY_LOGIN=true export ALLOW_DEPRECATED=true export PWFILE=users.yml diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 651d6b6e0..0693ea1cc 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -34,3 +34,5 @@ Modals: ^{modal "Klick mich für Ajax-Test" (Left UsersR)} ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")} + <li> + ^{modal "Email-Test" (Right emailWidget')} diff --git a/templates/correction-user.cassius b/templates/correction-user.cassius new file mode 100644 index 000000000..2b7b13b7a --- /dev/null +++ b/templates/correction-user.cassius @@ -0,0 +1,3 @@ +.comment + white-space: pre-wrap + font-family: monospace \ No newline at end of file diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index d0b8976e2..a3036193f 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -36,4 +36,4 @@ $maybe comment <- ratingComment <tr .table__row> <th .table__th>_{MsgRatingComment} - <td .table__td style="white-space: pre;">#{comment} + <td .table__td .comment>#{comment} diff --git a/templates/correction.hamlet b/templates/correction.hamlet index e26dbe7c4..9c5c0ed39 100644 --- a/templates/correction.hamlet +++ b/templates/correction.hamlet @@ -1,11 +1,10 @@ -^{userCorrection} +<section> + ^{userCorrection} -<hr> - -<form method=post enctype=#{corrEncoding}> - ^{corrForm} +<section> + <form method=post enctype=#{corrEncoding}> + ^{corrForm} -<hr> - -<form method=post enctype=#{uploadEncoding}> - ^{uploadForm} +<section> + <form method=post enctype=#{uploadEncoding}> + ^{uploadForm} diff --git a/templates/corrections-create.hamlet b/templates/corrections-create.hamlet new file mode 100644 index 000000000..4b1de86e1 --- /dev/null +++ b/templates/corrections-create.hamlet @@ -0,0 +1,2 @@ +<form method=post action=@{CorrectionsCreateR} enctype=#{pseudonymEncoding}> + ^{pseudonymWidget} diff --git a/templates/corrections-grade.hamlet b/templates/corrections-grade.hamlet new file mode 100644 index 000000000..f68d51e69 --- /dev/null +++ b/templates/corrections-grade.hamlet @@ -0,0 +1,5 @@ +<div .container> + <form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}> + ^{table} + <button type=submit> + _{MsgBtnSubmit} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 97968130e..9ab544bb6 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -185,6 +185,10 @@ h4 { p { margin: 10px 0; } + + p:last-child { + margin: 10px 0 0; + } } .logged-in { @@ -309,6 +313,10 @@ input[type="button"].btn-info:hover, width: 100%; } +.table:only-child { + margin: 0; +} + .table--striped { .table__row:not(.no-stripe):nth-child(even) { @@ -502,3 +510,20 @@ input[type="button"].btn-info:hover, padding-right: 15px; } } + +section { + padding: 0 0 12px; + margin: 0 0 12px; + border-bottom: 1px solid #d3d3d3; + +} + +section:last-of-type { + padding: 0; + margin: 0; + border-bottom: none; +} + +.pseudonym { + font-family: monospace; +} diff --git a/templates/deletedUser.hamlet b/templates/deletedUser.hamlet new file mode 100644 index 000000000..69b723987 --- /dev/null +++ b/templates/deletedUser.hamlet @@ -0,0 +1,16 @@ +<div .container> + <h1> + _{MsgUserAccountDeleted userDisplayName} + <div .container> + #{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht. + $if groupSubmissions > 0 + <div .container> + #{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank, + aber die Zuordnung zum Benutzer wurden gelöscht. + Gruppenabgaben können dadurch zu Einzelabgaben werden, + welche dann vom letzten Benutzer gelöscht werden können. + $if deletedSubmissionGroups > 0 + <div .container> + #{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden. + <div .container> + Good Bye! diff --git a/templates/help.hamlet b/templates/help.hamlet new file mode 100644 index 000000000..6d4b32bca --- /dev/null +++ b/templates/help.hamlet @@ -0,0 +1,4 @@ +_{MsgHelpIntroduction} + +<form method=post action=@{HelpR} enctype=#{formEnctype}> + ^{formWidget} diff --git a/templates/home.hamlet b/templates/home.hamlet index 8f5c3bafb..3995b864f 100644 --- a/templates/home.hamlet +++ b/templates/home.hamlet @@ -1,11 +1,5 @@ <div .container> - - <h1> + <h2> Kurse mit offener Registrierung <div .container> ^{courseTable} - - <h3> - Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a> - - ^{features} diff --git a/templates/homeUser.hamlet b/templates/homeUser.hamlet index c82ea98ef..479d27ab9 100644 --- a/templates/homeUser.hamlet +++ b/templates/homeUser.hamlet @@ -1,13 +1,10 @@ <div .container> - <h3> - Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a> - -<div .container> - <h1> + <h2> Anstehende Übungsblätter <div .container> ^{sheetTable} +<!-- <div .container> <h1> Anstehende Klausuren @@ -17,3 +14,4 @@ <h1> Anstehende Kursanmeldungen TODO +--> diff --git a/templates/mail/correctionsAssigned.hamlet b/templates/mail/correctionsAssigned.hamlet new file mode 100644 index 000000000..1f1b9c9e5 --- /dev/null +++ b/templates/mail/correctionsAssigned.hamlet @@ -0,0 +1,18 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + <body> + <h1> + _{MsgMailCorrectionsAssignedIntro (CI.original courseName) termDesc sheetName nbrSubs} + <p> + <a href=@{CorrectionsR}> + _{MsgCorrectionsTitle} + ^{editNotifications} \ No newline at end of file diff --git a/templates/mail/editNotifications.hamlet b/templates/mail/editNotifications.hamlet new file mode 100644 index 000000000..7ca5d9f8b --- /dev/null +++ b/templates/mail/editNotifications.hamlet @@ -0,0 +1,4 @@ +<p> + <a href=@{ProfileR}> + _{MsgProfileHeading} + \ _{MsgMailEditNotifications} \ No newline at end of file diff --git a/templates/mail/sheetActive.hamlet b/templates/mail/sheetActive.hamlet new file mode 100644 index 000000000..330914bc4 --- /dev/null +++ b/templates/mail/sheetActive.hamlet @@ -0,0 +1,18 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + <body> + <h1> + _{MsgMailSheetActiveIntro (CI.original courseName) termDesc sheetName} + <p> + <a href=@{CSheetR tid ssh csh shn SShowR}> + #{sheetName} + ^{editNotifications} \ No newline at end of file diff --git a/templates/mail/sheetInactive.hamlet b/templates/mail/sheetInactive.hamlet new file mode 100644 index 000000000..756736f42 --- /dev/null +++ b/templates/mail/sheetInactive.hamlet @@ -0,0 +1,18 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + <body> + <h1> + _{MsgMailSheetInactiveIntro (CI.original courseName) termDesc sheetName} + <p> + <a href=@{CSheetR tid ssh csh shn SShowR}> + #{sheetName} + ^{editNotifications} \ No newline at end of file diff --git a/templates/mail/sheetSoonInactive.hamlet b/templates/mail/sheetSoonInactive.hamlet new file mode 100644 index 000000000..fb27ad1ed --- /dev/null +++ b/templates/mail/sheetSoonInactive.hamlet @@ -0,0 +1,18 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + <body> + <h1> + _{MsgMailSheetSoonInactiveIntro (CI.original courseName) termDesc sheetName} + <p> + <a href=@{CSheetR tid ssh csh shn SShowR}> + #{sheetName} + ^{editNotifications} \ No newline at end of file diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet new file mode 100644 index 000000000..d808e4927 --- /dev/null +++ b/templates/mail/submissionRated.hamlet @@ -0,0 +1,66 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <style> + h1 { + font-size: 1.25em; + font-variant: small-caps; + font-weight: normal; + } + + .comment { + white-space: pre-wrap; + font-family: monospace; + } + <body> + <h1> + _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc} + <dl> + <dt> + _{MsgSubmission} + <dd> + <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}> + #{display csid} + $maybe User{..} <- corrector + <dt> + _{MsgRatingBy} + <dd> + #{display userDisplayName} + $maybe time <- submissionRatingTime' + <dt> + _{MsgRatingTime} + <dd> + #{time} + $maybe points <- submissionRatingPoints + $case sheetType + $of Bonus{..} + <dt> + _{MsgAchievedBonusPoints} + <dd> + _{MsgAchievedOf points maxPoints} + $of Normal{..} + <dt> + _{MsgAchievedNormalPoints} + <dd> + _{MsgAchievedOf points maxPoints} + $of Pass{..} + <dt> + _{MsgPassedResult} + <dd> + $if points >= passingPoints + _{MsgPassed} + $else + _{MsgNotPassed} + <dt> + _{MsgAchievedPassPoints} + <dd> + _{MsgPassAchievedOf points passingPoints maxPoints} + $of NotGraded + $maybe comment <- submissionRatingComment + <dt> + _{MsgRatingComment} + <dd .comment> + #{comment} + ^{editNotifications} diff --git a/templates/mail/submissionRated.txt b/templates/mail/submissionRated.txt new file mode 100644 index 000000000..1fa13f16f --- /dev/null +++ b/templates/mail/submissionRated.txt @@ -0,0 +1 @@ +#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)} diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet new file mode 100644 index 000000000..e8ba2fb77 --- /dev/null +++ b/templates/mail/support.hamlet @@ -0,0 +1,29 @@ +$newline never +\<!doctype html> +<html> + <head> + <meta charset="UTF-8"> + <body> + <dl> + $case userInfo + $of Left (Just email) + <dt> E-Mail + <dd> #{email} + $of Left Nothing + $of Right Nothing + <dt> Ungültige UserId erhalten! + $of Right (Just (Entity _ User{..})) + <dt> Name + <dd> #{userDisplayName} + <dt> E-Mail + <dd> #{userEmail} + $maybe matrnr <- userMatrikelnummer + <dt> Matrikelnummer + <dd> #{matrnr} + <dt> E-Mail Sprachen + $forall lang <- mailLanguages userMailLanguages + <dd> #{lang} + <dt> Zeit + <dd> #{rtime} + <p style="white-space: pre"> + #{jHelpRequest} diff --git a/templates/messages/submissionCreateDuplicates.hamlet b/templates/messages/submissionCreateDuplicates.hamlet new file mode 100644 index 000000000..3d54bcd75 --- /dev/null +++ b/templates/messages/submissionCreateDuplicates.hamlet @@ -0,0 +1,6 @@ +_{MsgSheetDuplicatePseudonym} + +<ul> + $forall p <- duplicate + <li .pseudonym> + #{review pseudonymText p} diff --git a/templates/messages/submissionCreateExisting.hamlet b/templates/messages/submissionCreateExisting.hamlet new file mode 100644 index 000000000..dd5c97dab --- /dev/null +++ b/templates/messages/submissionCreateExisting.hamlet @@ -0,0 +1,9 @@ +_{MsgSheetCreateExisting} + +<dl> + $forall (subId, pseudos) <- subs + <dt>#{toPathPiece subId} + <dd> + <ul> + $forall p <- pseudos + <li .pseudonym>#{review pseudonymText p} diff --git a/templates/messages/systemMessagesDeleted.hamlet b/templates/messages/systemMessagesDeleted.hamlet new file mode 100644 index 000000000..0252043a2 --- /dev/null +++ b/templates/messages/systemMessagesDeleted.hamlet @@ -0,0 +1,6 @@ +_{MsgSystemMessagesDeleted} + +<ul> + $forall sel <- selection + <li style="white-space: nowrap"> + #{toPathPiece sel} diff --git a/templates/messages/systemMessagesSetFrom.hamlet b/templates/messages/systemMessagesSetFrom.hamlet new file mode 100644 index 000000000..521fe4124 --- /dev/null +++ b/templates/messages/systemMessagesSetFrom.hamlet @@ -0,0 +1,6 @@ +_{MsgSystemMessagesActivated} + +<ul> + $forall sel <- selection + <li style="white-space: nowrap"> + #{toPathPiece sel} diff --git a/templates/messages/systemMessagesSetTo.hamlet b/templates/messages/systemMessagesSetTo.hamlet new file mode 100644 index 000000000..a024f3341 --- /dev/null +++ b/templates/messages/systemMessagesSetTo.hamlet @@ -0,0 +1,6 @@ +_{MsgSystemMessagesDeactivated} + +<ul> + $forall sel <- selection + <li style="white-space: nowrap"> + #{toPathPiece sel} diff --git a/templates/profile.hamlet b/templates/profile.hamlet index 45510425a..fc6a9bef7 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -1,62 +1,2 @@ <div .profile> - - <dl .deflist.profile-dl> - <dt .deflist__dt> _{MsgName} - <dd .deflist__dd> ^{nameWidget userDisplayName userSurname} - $maybe matnr <- userMatrikelnummer - <dt .deflist__dt> _{MsgMatrikelNr} - <dd .deflist__dd> #{matnr} - <dt .deflist__dt> _{MsgEMail} - <dd .deflist__dd> #{display userEmail} - <dt .deflist__dt> _{MsgIdent} - <dd .deflist__dd> #{display userIdent} - $if not $ null admin_rights - <dt .deflist__dt> Administrator - <dd .deflist__dd> - <ul .list-ul> - $forall (E.Value institute) <- admin_rights - <li .list-ul__item> - <a href=@{SchoolShowR $ SchoolKey institute}> - #{display institute} - $if not $ null lecturer_rights - <dt .deflist__dt> Lehrberechtigt - <dd .deflist__dd> - <ul .list-ul> - $forall (E.Value institute) <- lecturer_rights - <li .list-ul__item> - <a href=@{SchoolShowR $ SchoolKey institute}> - #{display institute} - $if not $ null lecture_corrector - <dt .deflist__dt> Korrektor - <dd .deflist__dd> - <ul .list-ul> - $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector - <li .list-ul__item> - <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh} - $if not $ null studies - <dt .deflist__dt> Studiengänge - <dd .deflist__dd> - <div .scrolltable> - <table .table.table--striped.table--hover.table--condensed> - <tr .table__row> - <th .table__th> Abschluss - <th .table__th> Studiengang - <th .table__th> Studienart - <th .table__th> Semester - - $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies - <tr.table__row> - <td .table__td> - $maybe name <- E.unValue degree - #{display name} - $nothing - #{display degreeKey} - <td .table__td> - $maybe name <- E.unValue field - #{display name} - $nothing - #{display fieldKey} - <td .table__td>_{E.unValue fieldtype} - <td .table__td>#{display semester} - ^{settingsForm} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 8d2b42a71..5acedae8e 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -1,9 +1,70 @@ -<div .container> - $if hasRows - <div .container> - <h2> Eigene Kurse +<div .profile> + + <dl .deflist.profile-dl> + <dt .deflist__dt> _{MsgName} + <dd .deflist__dd> ^{nameWidget userDisplayName userSurname} + $maybe matnr <- userMatrikelnummer + <dt .deflist__dt> _{MsgMatrikelNr} + <dd .deflist__dd> #{matnr} + <dt .deflist__dt> _{MsgEMail} + <dd .deflist__dd> #{display userEmail} + <dt .deflist__dt> _{MsgIdent} + <dd .deflist__dd> #{display userIdent} + $if not $ null admin_rights + <dt .deflist__dt> Administrator + <dd .deflist__dd> + <ul .list-ul> + $forall (E.Value institute) <- admin_rights + <li .list-ul__item> + <a href=@{SchoolShowR $ SchoolKey institute}> + #{display institute} + $if not $ null lecturer_rights + <dt .deflist__dt> Lehrberechtigt + <dd .deflist__dd> + <ul .list-ul> + $forall (E.Value institute) <- lecturer_rights + <li .list-ul__item> + <a href=@{SchoolShowR $ SchoolKey institute}> + #{display institute} + $if not $ null lecture_corrector + <dt .deflist__dt> Korrektor + <dd .deflist__dd> + <ul .list-ul> + $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector + <li .list-ul__item> + <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh} + $if not $ null studies + <dt .deflist__dt> Studiengänge + <dd .deflist__dd> + <div .scrolltable> + <table .table.table--striped.table--hover.table--condensed> + <tr .table__row> + <th .table__th> Abschluss + <th .table__th> Studiengang + <th .table__th> Studienart + <th .table__th> Semester + + $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies + <tr.table__row> + <td .table__td> + $maybe name <- E.unValue degree + #{display name} + $nothing + #{display degreeKey} + <td .table__td> + $maybe name <- E.unValue field + #{display name} + $nothing + #{display fieldKey} + <td .table__td>_{E.unValue fieldtype} + <td .table__td>#{display semester} + + <div .container> + $if hasRows <div .container> - ^{ownedCoursesTable} + <h2> Eigene Kurse + <div .container> + ^{ownedCoursesTable} <div .container> <h2> Kursanmeldungen diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 012ada784..9efdc5e24 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -1,33 +1,34 @@ -<div .container> - $maybe descr <- sheetDescription sheet - <h2 #description>Hinweise - <p> #{descr} - - <h3>Bewertung - <p> - #{display $ sheetType sheet} - - $maybe marking <- sheetMarkingText sheet +$newline never +$maybe descr <- sheetDescription sheet + <section> + <h2 #description>_{MsgSheetDescription} <p> - #{marking} + #{descr} - <p> - Download und Abgabe freigeschaltet ab - #{sheetFrom} +<section> + <dl .deflist> + <dt .deflist__dt>_{MsgSheetActiveFrom} + <dd .deflist__dd>#{sheetFrom} + <dt .deflist__dt>_{MsgSheetActiveTo} + <dd .deflist__dd>#{sheetTo} + $maybe hints <- hintsFrom <* guard hasHints + <dt .deflist__dt>_{MsgSheetHintFrom} + <dd .deflist__dd>#{hints} + $maybe solution <- solutionFrom <* guard hasSolution + <dt .deflist__dt>_{MsgSheetSolutionFrom} + <dd .deflist__dd>#{solution} + <dt .deflist__dt>_{MsgSheetType} + <dd .deflist__dd>_{sheetType sheet} + $if CorrectorSubmissions == sheetSubmissionMode sheet + <dt .deflist__dt>_{MsgSheetPseudonym} + <dd .deflist__dd #pseudonym> + $maybe pseudonym <- mPseudonym + <span .pseudonym>#{pseudonym} + $nothing + <form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}> + ^{generateWidget} - <p> - Abgabe bis - #{sheetTo} - - $maybe hints <- hintsFrom <* guard hasHints - <p> - Hinweise ab - #{hints} - - $maybe solution <- solutionFrom <* guard hasSolution - <p> - Lösung ab - #{solution} - - <h2>Dateien - ^{fileTable} +$if hasFiles + <section> + <h2>_{MsgSheetFiles} + ^{fileTable} diff --git a/templates/standalone/alerts.lucius b/templates/standalone/alerts.lucius index c1660b903..c2479508d 100644 --- a/templates/standalone/alerts.lucius +++ b/templates/standalone/alerts.lucius @@ -82,6 +82,10 @@ transition: margin-bottom .2s ease-out; } +.alert a { + color: var(--color-lightwhite); +} + @keyframes slide-in-alert { from { transform: translateY(120%); diff --git a/templates/standalone/modal.julius b/templates/standalone/modal.julius index 8bac72f12..77a8f2252 100644 --- a/templates/standalone/modal.julius +++ b/templates/standalone/modal.julius @@ -56,6 +56,7 @@ if (modal.dataset.dynamic === 'True') { var dynamicContentURL = trigger.getAttribute('href'); + console.log(dynamicContentURL); if (dynamicContentURL.length > 0) { fetch(dynamicContentURL, { credentials: 'same-origin', diff --git a/templates/standalone/modal.lucius b/templates/standalone/modal.lucius index 589083ece..e14dbad72 100644 --- a/templates/standalone/modal.lucius +++ b/templates/standalone/modal.lucius @@ -16,11 +16,13 @@ overflow: auto; opacity: 0; transition: all .15s ease; + pointer-events: none; &.modal--open { opacity: 1; z-index: 200; transform: translate(-50%, -50%) scale(1, 1); + pointer-events: all; } } diff --git a/templates/submission.hamlet b/templates/submission.hamlet index aeaf9ca2f..c9686bd3b 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -13,7 +13,7 @@ $maybe cID <- mcid <p> _{MsgSubmissionNoUploadExpected} - $if not (null lastEdits) + $if maySubmit && not (null lastEdits) <h3>_{MsgLastEdits} <ul> $forall (mbName,time) <- lastEdits diff --git a/templates/system-message-list.hamlet b/templates/system-message-list.hamlet new file mode 100644 index 000000000..52475c44c --- /dev/null +++ b/templates/system-message-list.hamlet @@ -0,0 +1,9 @@ +<section> + <form method=post action=@{MessageListR} encytpe=#{tableEncoding}> + ^{tableView} + <button type=submit> + _{MsgBtnSubmit} + +<section> + <form method=post action=@{MessageListR} enctype=#{addEncoding}> + ^{addView} diff --git a/templates/system-message.hamlet b/templates/system-message.hamlet new file mode 100644 index 000000000..0775ebe58 --- /dev/null +++ b/templates/system-message.hamlet @@ -0,0 +1,24 @@ +<section> + $maybe summary' <- summary + <h2> + #{summary'} + <p> + #{content} + +$maybe (((_, modifyView), modifyEnctype), modifyTranss, ((_, addTransView), addTransEnctype)) <- forms + <section> + <h2>_{MsgSystemMessageEdit} + <form method=post action=@{MessageR cID} enctype=#{modifyEnctype}> + ^{modifyView} + + <section> + <h2>_{MsgSystemMessageAddTranslation} + <form method=post action=@{MessageR cID} enctype=#{addTransEnctype}> + ^{addTransView} + + $if not (null modifyTranss) + <section> + <h2>_{MsgSystemMessageEditTranslations} + $forall ((_, transView), transEnctype) <- modifyTranss + <form method=post action=@{MessageR cID} enctype=#{transEnctype}> + ^{transView} diff --git a/templates/versionHistory.hamlet b/templates/versionHistory.hamlet index 859356ca5..bee7bee3e 100644 --- a/templates/versionHistory.hamlet +++ b/templates/versionHistory.hamlet @@ -10,11 +10,11 @@ Bekannte Bugs <ul> <li> - Umlaute in Benutzernamen werden durch externes LDAP-Plugin entfernt + Login ist u.U. anders als im alten System, z.B. <span style="font-family:monospace">@campus.lmu.de</span> statt <span style="font-family:monospace">@lmu.de</span> <li> - Auswahlbox "alle markieren" fehlt noch + Favicon ist default des Frameworks <li> - Tabellen über mehrere Seiten müssen vor Seitenwechsel manuell sortiert werden + Format von Bewertungsdateien ist provisorisch <section> <h2> @@ -26,7 +26,7 @@ <h2> Impressum - <ul> + <ul style="list-style-type: none"> <li> Dr Steffen Jost <li> diff --git a/templates/widgets/form.julius b/templates/widgets/form.julius index b36ea327b..90a1f53b1 100644 --- a/templates/widgets/form.julius +++ b/templates/widgets/form.julius @@ -36,7 +36,6 @@ }; window.utils.interactiveFieldset = function(form, fieldSets) { - var fields = fieldSets.map(function(fs) { return { fieldSet: fs, diff --git a/templates/widgets/form.lucius b/templates/widgets/form.lucius index 094758416..d4e06f591 100644 --- a/templates/widgets/form.lucius +++ b/templates/widgets/form.lucius @@ -1,10 +1,3 @@ -.hidden { - visibility: hidden; - height: 0; - opacity: 0; -} - - fieldset { border: 0; margin: 20px 0 30px; @@ -13,3 +6,14 @@ fieldset { display: none; } } + +.form-group__input > fieldset { + margin-bottom: 0; +} + +.hidden { + visibility: hidden; + height: 0; + opacity: 0; + margin: 0; +} diff --git a/templates/widgets/navbar.hamlet b/templates/widgets/navbar.hamlet index 7cac27a12..8f2e8ec69 100644 --- a/templates/widgets/navbar.hamlet +++ b/templates/widgets/navbar.hamlet @@ -12,26 +12,32 @@ $newline never <i .fas.fa-star> <div .navbar__link-label> Favorites - $forall menuType <- menuTypes + $forall (menuType, menuIdent) <- menuTypes $case menuType - $of NavbarAside (MenuItem label mIcon route _) + $of NavbarAside (MenuItem label mIcon route _ isModal) <li .navbar__list-item :highlight route:.navbar__list-item--active> - <a .navbar__link-wrapper href=@{route}> + $if isModal + <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> + <a .navbar__link-wrapper href=@{route} ##{menuIdent}> <i .fas.fa-#{fromMaybe "none" mIcon}> <div .navbar__link-label>#{label} $of _ <ul .navbar__list.list--inline> - $forall menuType <- menuTypes + $forall (menuType, menuIdent) <- menuTypes $case menuType - $of NavbarRight (MenuItem label mIcon route _) + $of NavbarRight (MenuItem label mIcon route _ isModal) <li .navbar__list-item :Just route == mcurrentRoute:.navbar__list-item--active> - <a .navbar__link-wrapper href=@{route}> + $if isModal + <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> + <a .navbar__link-wrapper href=@{route} ##{menuIdent}> <i .fas.fa-#{fromMaybe "none" mIcon}> <div .navbar__link-label>#{label} - $of NavbarSecondary (MenuItem label mIcon route _) + $of NavbarSecondary (MenuItem label mIcon route _ isModal) <li .navbar__list-item.navbar__list-item--secondary :Just route == mcurrentRoute:.navbar__list-item--active> - <a .navbar__link-wrapper href=@{route}> + $if isModal + <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> + <a .navbar__link-wrapper href=@{route} ##{menuIdent}> <i .fas.fa-#{fromMaybe "none" mIcon}> <div .navbar__link-label>#{label} $of _ diff --git a/templates/widgets/pageactionprime.hamlet b/templates/widgets/pageactionprime.hamlet index cce7e13e3..36288f84b 100644 --- a/templates/widgets/pageactionprime.hamlet +++ b/templates/widgets/pageactionprime.hamlet @@ -2,12 +2,16 @@ $newline never $if hasPageActions <div .page-nav-prime> <ul .pagenav__list> - $forall menuType <- menuTypes + $forall (menuType, menuIdent) <- menuTypes $case menuType - $of PageActionPrime (MenuItem label _mIcon route _callback) + $of PageActionPrime (MenuItem label _mIcon route _callback isModal) <li .pagenav__list-item> - <a .pagenav__link-wrapper href=@{route}>#{label} - $of PageActionSecondary (MenuItem label _mIcon route _callback) + $if isModal + <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> + <a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label} + $of PageActionSecondary (MenuItem label _mIcon route _callback isModal) <li .pagenav__list-item> - <a .pagenav__link-wrapper href=@{route}>#{label} + $if isModal + <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> + <a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label} $of _ diff --git a/templates/widgets/permutation.hamlet b/templates/widgets/permutation.hamlet new file mode 100644 index 000000000..ac5ee008a --- /dev/null +++ b/templates/widgets/permutation.hamlet @@ -0,0 +1,7 @@ +$newline never +<ul ##{theId}> + $forall (n, selId) <- nums + <li> + <select ##{selId} name=#{name} :isReq:required *{attrs}> + $forall opt <- olOptions + <option value=#{withNum (optionExternalValue opt) n} :isSel n opt:selected>#{optionDisplay opt} diff --git a/templates/widgets/permutation.lucius b/templates/widgets/permutation.lucius new file mode 100644 index 000000000..0ae9d74e5 --- /dev/null +++ b/templates/widgets/permutation.lucius @@ -0,0 +1,3 @@ +##{theId} { + list-style-type: none; +} diff --git a/test.sh b/test.sh new file mode 100755 index 000000000..9e3db3ebe --- /dev/null +++ b/test.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +move-back() { + mv -v .stack-work .stack-work-test + [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work +} + +if [[ -d .stack-work-test ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run + mv -v .stack-work-test .stack-work + trap move-back EXIT +fi + +stack test --flag uniworx:dev --flag uniworx:library-only ${@} diff --git a/test/CronSpec.hs b/test/CronSpec.hs new file mode 100644 index 000000000..af942ea77 --- /dev/null +++ b/test/CronSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module CronSpec where + +import TestImport + +import Cron +import Numeric.Natural + +import Data.Time +import Data.Time.Clock.System +import Data.Time.Zones + +import Data.List (iterate) + + +baseTime :: UTCTime +baseTime = UTCTime (addDays 58400 systemEpochDay) 50000 + + +sampleCron :: Natural -> Cron -> [UTCTime] +sampleCron n = go n baseTime Nothing + where + go 0 _ _ _ = [] + go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of + MatchAsap -> t : go (pred n) t (Just t) cron + MatchAt t' -> t' : go (pred n) t' (Just t') cron + MatchNone -> [] + + +spec :: Spec +spec = do + describe "Cron" $ do + it "generates correct example series" . mapM_ seriesExample $ + [ (Cron CronAsap Nothing CronScheduleBefore, [baseTime]) + , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime) + ] + +seriesExample :: (Cron, [UTCTime]) -> Expectation +seriesExample (cron, res) = example $ sampleCron 10 cron `shouldBe` take 10 res diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index dff41b58b..e0f8ed5c2 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -4,6 +4,8 @@ module Handler.ProfileSpec (spec) where import TestImport +import qualified Data.CaseInsensitive as CI + spec :: Spec spec = withApp $ do @@ -13,16 +15,16 @@ spec = withApp $ do statusIs 403 it "asserts access to my-account for authenticated users" $ do - userEntity <- createUser "dummy" "foo" + userEntity <- createUser "foo" authenticateAs userEntity get ProfileR statusIs 200 it "asserts user's information is shown" $ do - userEntity <- createUser "dummy" "bar" + userEntity <- createUser "bar" authenticateAs userEntity get ProfileR let (Entity _ user) = userEntity - htmlAnyContain ".username" . unpack $ userIdent user + htmlAnyContain ".username" . unpack . CI.original $ userIdent user diff --git a/test/TestImport.hs b/test/TestImport.hs index 29f09bdc6..bf7f56729 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -25,6 +25,13 @@ import Test.QuickCheck.Gen as X import Data.Default as X import Test.QuickCheck.Instances as X + +import Settings + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do app <- getTestYesod @@ -79,12 +86,24 @@ authenticateAs :: Entity User -> YesodExample UniWorX () authenticateAs (Entity _ User{..}) = do request $ do setMethod "POST" - addPostParam "ident" $ userPlugin <> ":" <> userIdent + addPostParam "ident" $ CI.original userIdent setUrl $ AuthR $ PluginR "dummy" [] -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. -createUser :: Text -> Text -> YesodExample UniWorX (Entity User) -createUser userPlugin userIdent = runDB $ insertEntity User{..} - where - userMatrikelnummer = "DummyMatrikelnummer" +createUser :: CI Text -> YesodExample UniWorX (Entity User) +createUser userIdent = do + UserDefaultConf{..} <- appUserDefaults . appSettings <$> getTestYesod + let + userMatrikelnummer = Nothing + userAuthentication = AuthLDAP + userEmail = "dummy@example.invalid" + userDisplayName = "Dummy Example" + userSurname = "Example" + userTheme = userDefaultTheme + userMaxFavourites = userDefaultMaxFavourites + userDateTimeFormat = userDefaultDateTimeFormat + userDateFormat = userDefaultDateFormat + userTimeFormat = userDefaultTimeFormat + userDownloadFiles = userDefaultDownloadFiles + runDB $ insertEntity User{..} diff --git a/testdata/AbgabeH10-1.hs b/testdata/AbgabeH10-1.hs new file mode 100644 index 000000000..07a3d0124 --- /dev/null +++ b/testdata/AbgabeH10-1.hs @@ -0,0 +1,3 @@ +Abgabe zu H10-1: + + Ich habe keine Ahnung wie ich die H10-1 lösen soll, sorry!