fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into 126-ubungsbetrieb-statistik-seiten-pro-kurs

Browse Source
This commit is contained in:
SJost 2018-12-21 17:12:20 +01:00
commit 4b58f42ab6
38 changed files with 532 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/button/de.msg Normal file
View File

@ -0,0 +1,3 @@
AmbiguousButtons: Mehrere Submit-Buttons aktiv
WrongButtonValue: Submit-Button hat falschen Wert
MultipleButtonValues: Submit-Button hat mehrere Werte

3
messages/dummy/de.msg
View File

@ -1 +1,2 @@
DummyIdent: Nutzer-Kennung
DummyIdent: Nutzer-Kennung
DummyNoFormData: Keine Formulardaten empfangen

16
messages/uniworx/de.msg
View File

@ -93,6 +93,7 @@ SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
SheetDeleted: Übungsblatt gelöscht
@ -194,6 +195,7 @@ AddCorrector: Zusätzlicher Korrektor
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion
AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
Corrector: Korrektor
Correctors: Korrektoren
CorState: Status
@ -244,6 +246,7 @@ CorrUploadField: Korrekturen
CorrUpload: Korrekturen hochladen
CorrSetCorrector: Korrektor zuweisen
CorrAutoSetCorrector: Korrekturen verteilen
CorrDelete: Abgaben löschen
NatField name@Text: #{name} muss eine natürliche Zahl sein!
JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
@ -387,11 +390,17 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co
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.
MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden
MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{tshow n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden.
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: Abgabfrist 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.
MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
MailEditNotifications: Benachrichtigungen ein-/ausschalten
MailSubjectSupport: Supportanfrage
@ -415,8 +424,8 @@ SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die B
SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
SummaryTitle: Zusammenfassung über alle
SheetGradingSummaryTitle count@Integer: #{display count} #{pluralDE count "Blatt" "Blätter"}
SubmissionGradingSummaryTitle count@Integer: #{display count} #{pluralDE count "Abgabe" "Abgaben"}
SheetGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Blatt" "Blätter"}
SubmissionGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Abgabe" "Abgaben"}
SheetTypeBonus': Bonus
SheetTypeNormal': Normal
@ -439,6 +448,7 @@ NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"

1
models/sheets
View File

@ -12,6 +12,7 @@ Sheet
solutionFrom UTCTime Maybe
uploadMode UploadMode
submissionMode SheetSubmissionMode default='UserSubmissions'
autoDistribute Bool default=false
CourseSheet course name
SheetEdit
user UserId

7
src/Auth/Dummy.hs
View File

@ -13,10 +13,12 @@ import qualified Data.CaseInsensitive as CI
data DummyMessage = MsgDummyIdent
| MsgDummyNoFormData
dummyForm :: ( RenderMessage site FormMessage
, RenderMessage site DummyMessage
, RenderMessage site ButtonMessage
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, Button site SubmitButton
@ -33,6 +35,7 @@ dummyLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site DummyMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => AuthPlugin site
@ -46,7 +49,9 @@ dummyLogin = AuthPlugin{..}
FormFailure errs -> do
lift . forM_ errs $ addMessage Error . toHtml
redirect LoginR
FormMissing -> redirect LoginR
FormMissing -> do
lift $ addMessageI Warning MsgDummyNoFormData
redirect LoginR
FormSuccess ident ->
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
apDispatch _ _ = notFound

2
src/Auth/LDAP.hs
View File

@ -53,6 +53,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName"
campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => AForm (HandlerT site IO) CampusLogin
@ -65,6 +66,7 @@ campusLogin :: forall site.
( YesodAuth site
, RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => LdapConf -> LdapPool -> AuthPlugin site

2
src/Auth/PWHash.hs
View File

@ -27,6 +27,7 @@ data PWHashMessage = MsgPWHashIdent
hashForm :: ( RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => AForm (HandlerT site IO) HashLogin
@ -41,6 +42,7 @@ hashLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => PWHashAlgorithm -> AuthPlugin site

1
src/Foundation.hs
View File

@ -161,6 +161,7 @@ mkMessage "UniWorX" "messages/uniworx" "de"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.

35
src/Handler/Corrections.hs
View File

@ -8,6 +8,7 @@ import Handler.Utils
import Handler.Utils.Submission
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
import Handler.Utils.Delete
-- import Handler.Utils.Zip
import Utils.Lens
@ -39,8 +40,6 @@ import qualified Database.Esqueleto as E
-- import Network.Mime
import Web.PathPieces
import Text.Hamlet (ihamletFile)
import Database.Persist.Sql (updateWhereCount)
@ -286,24 +285,29 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = d
data ActionCorrections = CorrDownload
| CorrSetCorrector
| CorrAutoSetCorrector
| CorrDelete
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance PathPiece ActionCorrections where
fromPathPiece = readFromPathPiece
toPathPiece = showToPathPiece
instance RenderMessage UniWorX ActionCorrections where
renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
instance Universe ActionCorrections
instance Finite ActionCorrections
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ActionCorrections id
data ActionCorrectionsData = CorrDownloadData
| CorrSetCorrectorData (Maybe UserId)
| CorrAutoSetCorrectorData SheetId
| CorrDeleteData
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
{ drAbort = SomeRoute currentRoute
, drSuccess = SomeRoute currentRoute
}
((actionRes', table), statistics) <- runDB $ do
-- Query for Table
tableRes <- makeCorrectionsTable whereClause displayColumns psValidator return def
@ -395,6 +399,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute
FormSuccess (CorrDeleteData, subs) -> do
subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
getDeleteR (submissionDeleteRoute subs')
{ drAbort = SomeRoute currentRoute
, drSuccess = SomeRoute currentRoute
}
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
@ -415,10 +425,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
downloadAction :: ActionCorrections'
downloadAction, deleteAction :: ActionCorrections'
downloadAction = ( CorrDownload
, pure CorrDownloadData
)
deleteAction = ( CorrDelete
, pure CorrDeleteData
)
assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
@ -490,6 +503,7 @@ postCCorrectionsR tid ssh csh = do
correctionsR whereClause colonnade psValidator $ Map.fromList
[ downloadAction
, assignAction (Left cid)
, deleteAction
]
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
@ -513,6 +527,7 @@ postSSubsR tid ssh csh shn = do
[ downloadAction
, assignAction (Right shid)
, autoAssignAction shid
, deleteAction
]
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _

25
src/Handler/Course.hs
View File

@ -6,6 +6,7 @@ import Utils.Lens
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Table.Cells
import Handler.Utils.Course
import Handler.Utils.Delete
-- import Data.Time
@ -391,28 +392,10 @@ getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Ht
getCDeleteR = postCDeleteR
postCDeleteR tid ssh csh = do
Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
deleteR DeleteRoute
{ drRecords = Set.singleton cId
, drRenderRecord = \(Entity _ Course{courseName, courseTerm, courseSchool}) -> do
School{schoolName} <- getJust courseSchool
return [whamlet|
#{courseName} (_{SomeMessage $ ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName})
|]
, drRecordConfirmString = \(Entity _ Course{courseShorthand, courseTerm, courseSchool}) ->
return [st|#{unSchoolKey courseSchool}/#{termToText (unTermKey courseTerm)}/#{courseShorthand}|]
, drCaption = SomeMessage MsgCourseDeleteQuestion
, drSuccessMessage = SomeMessage MsgCourseDeleted
, drAbort = SomeRoute $ CourseR tid ssh csh CShowR
, drSuccess = SomeRoute CourseListR
deleteR $ (courseDeleteRoute $ Set.singleton cId)
{ drAbort = SomeRoute $ CourseR tid ssh csh CShowR
, drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
}
{- TODO
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
, Just cid <- cfCourseId res -> do
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
let cti = toPathPiece $ cfTerm res
addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
redirect $ TermCourseListR $ cfTerm res
-}
-- | Course Creation and Editing

6
src/Handler/Profile.hs
View File

@ -106,9 +106,9 @@ postProfileDataR = do
defaultLayout
$(widgetFile "deletedUser")
(FormSuccess BtnAbort ) -> do
addMessageI Info MsgAborted
redirect ProfileDataR
-- (FormSuccess BtnAbort ) -> do
-- addMessageI Info MsgAborted
-- redirect ProfileDataR
_other -> getProfileDataR

61
src/Handler/Sheet.hs
View File

@ -498,6 +498,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
, sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = False
}
mbsid <- dbAction newSheet
case mbsid of
@ -533,20 +534,8 @@ getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Han
getSDelR = postSDelR
postSDelR tid ssh csh shn = do
sid <- runDB $ fetchSheetId tid ssh csh shn
deleteR DeleteRoute
{ drRecords = Set.singleton sid
, drRenderRecord = \(Entity _ Sheet{sheetName, sheetCourse}) -> do
Course{courseTerm, courseSchool, courseName} <- getJust sheetCourse
School{schoolName} <- getJust courseSchool
return [whamlet|
#{sheetName} (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName})
|]
, drRecordConfirmString = \(Entity _ Sheet{sheetName, sheetCourse}) -> do
Course{courseTerm, courseSchool, courseShorthand} <- getJust sheetCourse
return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}|]
, drCaption = SomeMessage MsgSheetDeleteQuestion
, drSuccessMessage = SomeMessage MsgSheetDeleted
, drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
deleteR $ (sheetDeleteRoute $ Set.singleton sid)
{ drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
}
@ -608,7 +597,7 @@ defaultLoads shid = do
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
cListIdent <- newFormIdent
let
@ -621,7 +610,7 @@ correctorForm shid = do
let
currentLoads :: DB Loads
currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
(autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
@ -633,6 +622,7 @@ correctorForm shid = do
didDelete = any (flip Set.member deletions) formCIDs
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
(autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
let
tutorField :: Field Handler [UserEmail]
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
@ -726,23 +716,25 @@ correctorForm shid = do
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
return (corrResults, [ countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
return ( (,) <$> autoDistributeRes <*> corrResults
, [ autoDistributeView
, countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
-- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
@ -756,7 +748,8 @@ getSCorrR tid ssh csh shn = do
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess res' -> runDB $ do
FormSuccess (autoDistribute, res') -> runDB $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res'
addMessageI Success MsgCorrectorsUpdated

28
src/Handler/Submission.hs
View File

@ -20,7 +20,6 @@ import Network.Mime
import Data.Monoid (Any(..))
import Data.Maybe (fromJust)
-- import qualified Data.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.CaseInsensitive (CI)
@ -397,30 +396,7 @@ getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName ->
getSubDelR = postSubDelR
postSubDelR tid ssh csh shn cID = do
subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID
deleteR DeleteRoute
{ drRecords = Set.singleton subId
, drRenderRecord = \(Entity subId' Submission{submissionSheet}) -> do
Sheet{sheetName, sheetCourse} <- getJust submissionSheet
Course{courseName, courseSchool, courseTerm} <- getJust sheetCourse
School{schoolName} <- getJust courseSchool
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
return [whamlet|
$newline never
<ul .list--comma-separated .list--inline .list--iconless>
$forall (dName, sName) <- subNames
<li>^{nameWidget dName sName}
&nbsp;(_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}, #{sheetName})
|]
, drRecordConfirmString = \(Entity subId' Submission{submissionSheet}) -> do
Sheet{sheetName, sheetCourse} <- getJust submissionSheet
Course{courseShorthand, courseSchool, courseTerm} <- getJust sheetCourse
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
let subNames' = Text.intercalate ", " subNames
return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}/#{subNames'}|]
, drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
, drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
, drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
deleteR $ (submissionDeleteRoute $ Set.singleton subId)
{ drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
, drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
}

27
src/Handler/Utils/Course.hs Normal file
View File

@ -0,0 +1,27 @@
module Handler.Utils.Course where
import Import
import Handler.Utils.Delete
import qualified Database.Esqueleto as E
courseDeleteRoute :: Set CourseId -> DeleteRoute Course
courseDeleteRoute drRecords = DeleteRoute
{ drRecords
, drGetInfo = \(course `E.InnerJoin` school) -> do
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.orderBy [E.asc $ course E.^. CourseName]
return (course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
, drUnjoin = \(course `E.InnerJoin` _) -> course
, drRenderRecord = \(E.Value cName, _, E.Value sName, E.Value tid') ->
return [whamlet|
#{cName} (_{ShortTermIdentifier (unTermKey tid')}, #{sName})
|]
, drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') ->
return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|]
, drCaption = SomeMessage MsgCourseDeleteQuestion
, drSuccessMessage = SomeMessage MsgCourseDeleted
, drAbort = error "drAbort undefined"
, drSuccess = error "drSuccess undefined"
}

113
src/Handler/Utils/Delete.hs
View File

@ -1,6 +1,7 @@
module Handler.Utils.Delete
( DeleteRoute(..)
, deleteR
, postDeleteR, getDeleteR
) where
import Import
@ -13,63 +14,89 @@ import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
import Control.Monad.Trans.Random
import System.Random (mkStdGen)
import System.Random.Shuffle (shuffleM)
import qualified Crypto.Hash as Crypto (hash)
import Crypto.Hash (Digest, SHAKE128)
import qualified Data.ByteArray as ByteArray
import Data.Char (isAlphaNum)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
import qualified Database.Esqueleto.Internal.Language as E (From)
data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute
{ drRecords :: Set (Key record)
, drRenderRecord :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
, drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
, drUnjoin :: tables -> E.SqlExpr (Entity record)
, drGetInfo :: tables -> E.SqlQuery infoExpr
, drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
, drCaption
, drSuccessMessage :: SomeMessage UniWorX
, drAbort
, drSuccess :: SomeRoute UniWorX
}
confirmForm :: ( MonadHandler m, HandlerSite m ~ UniWorX )
=> Text -- ^ Confirmation string
-> AForm m Bool
confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelete) -> if
| ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
-> return $ pure True
| otherwise
-> formFailure [MsgDeleteConfirmationWrong]
where
aform = (,)
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
<*> disambiguateButtons (combinedButtonFieldF "")
confirmField
| multiple = convertField unTextarea Textarea textareaField
| otherwise = textField
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
deleteR :: DeleteRoute -> Handler Html
deleteR DeleteRoute{..} = do
targets <- runDB . mconcatForM drRecords $ \rKey -> do
ent <- Entity rKey <$> get404 rKey
recordWdgt <- drRenderRecord ent
recordConfirmString <- drRecordConfirmString ent
return $ pure (recordWdgt, recordConfirmString)
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
where
addDeleteTargets :: Form a -> Form a
addDeleteTargets form csrf = do
(_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
over _2 (mappend $ fvInput fvTargets) <$> form csrf
cIDKey <- hash . (ByteArray.convert :: Digest (SHAKE128 64) -> ByteString) . Crypto.hash <$> getsYesod appCryptoIDKey
let sTargets = evalRand (shuffleM targets) . mkStdGen . hashWithSalt cIDKey $ Set.toList drRecords
confirmString = Text.unlines $ map (Text.strip . view _2) sTargets
confirmField
| Set.size drRecords <= 1 = textField
| otherwise = convertField unTextarea Textarea textareaField
((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,)
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
<*> combinedButtonFieldF ""
postDeleteR :: ( DeleteCascade record SqlBackend )
=> (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys
-> Handler ()
-- | Perform deletion
postDeleteR mkRoute = do
drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget
formResult deleteFormRes $ \case
(_, catMaybes -> [BtnAbort]) ->
redirect drAbort
(inpConfirmStr, catMaybes -> [BtnDelete])
| ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
-> do
runDB $ do
forM_ drRecords deleteCascade
addMessageI Success drSuccessMessage
redirect drSuccess
| otherwise
-> addMessageI Error MsgDeleteConfirmationWrong
_other -> return ()
void . for drResult $ \DeleteRoute{..} -> do
confirmString <- fmap Text.unlines . runDB $ mapM drRecordConfirmString <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
formResult confirmRes $ \case
True -> do
runDB $ do
forM_ drRecords deleteCascade
addMessageI Success drSuccessMessage
redirect drSuccess
False ->
redirect drAbort
getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a
getDeleteR DeleteRoute{..} = do
targets <- runDB $ mapM (\i -> (,) <$> drRenderRecord i <*> drRecordConfirmString i) <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
let confirmString = Text.unlines $ view _2 <$> targets
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
Just targetRoute <- getCurrentRoute
defaultLayout
$(widgetFile "widgets/delete-confirmation")
sendResponse =<<
defaultLayout $(widgetFile "widgets/delete-confirmation")
deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html
deleteR dr = do
postDeleteR $ \drRecords -> dr {drRecords}
getDeleteR dr

29
src/Handler/Utils/Form.hs
View File

@ -23,8 +23,6 @@ import qualified Data.Text as T
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3
import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Handler.Utils.Zip
import qualified Data.Conduit.List as C
@ -53,29 +51,26 @@ import Data.Aeson.Text (encodeToLazyText)
-- Buttons (new version ) --
----------------------------
data BtnDelete = BtnDelete | BtnAbort
data BtnDelete = BtnDelete
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance Universe BtnDelete
instance Finite BtnDelete
instance PathPiece BtnDelete where -- for displaying the button only, not really for paths
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
instance Button UniWorX BtnDelete where
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
label BtnAbort = [whamlet|_{MsgBtnAbort}|]
cssClass BtnDelete = BCDanger
cssClass BtnAbort = BCDefault
data RegisterButton = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece RegisterButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe RegisterButton
instance Finite RegisterButton
nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1
instance Button UniWorX RegisterButton where
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
@ -87,9 +82,10 @@ instance Button UniWorX RegisterButton where
data AdminHijackUserButton = BtnHijack
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece AdminHijackUserButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe AdminHijackUserButton
instance Finite AdminHijackUserButton
nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1
instance Button UniWorX AdminHijackUserButton where
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
@ -109,7 +105,10 @@ instance Button UniWorX BtnSubmitDelete where
cssClass BtnSubmit' = BCPrimary
cssClass BtnDelete' = BCDanger
nullaryPathPiece ''BtnSubmitDelete (camelToPathPiece' 1 . dropSuffix "'")
btnValidate _ BtnSubmit' = True
btnValidate _ BtnDelete' = False
nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)

31
src/Handler/Utils/Sheet.hs
View File

@ -1,13 +1,12 @@
module Handler.Utils.Sheet where
import Import
import Handler.Utils.Delete
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, E.SqlSelect b a
, Typeable a, MonadHandler m, IsPersistBackend backend
@ -41,3 +40,31 @@ fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ss
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet
sheetDeleteRoute drRecords = DeleteRoute
{ drRecords
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let submissions = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
return E.countRows
E.orderBy [E.asc $ sheet E.^. SheetName]
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
, drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') ->
return [whamlet|
$newline never
#{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName})
$if submissions /= 0
&nbsp;<i>_{SomeMessage $ MsgSheetDelHasSubmissions submissions}
|]
, drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') ->
return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
, drCaption = SomeMessage MsgSheetDeleteQuestion
, drSuccessMessage = SomeMessage MsgSheetDeleted
, drAbort = error "drAbort undefined"
, drSuccess = error "drSuccess undefined"
}

45
src/Handler/Utils/Submission.hs
View File

@ -8,10 +8,11 @@ module Handler.Utils.Submission
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
, sinkSubmission, sinkMultiSubmission
, submissionMatchesSheet
, submissionDeleteRoute
) where
import Import hiding (joinPath)
import Jobs
import Jobs.Queue
import Prelude (lcm)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
@ -37,11 +38,10 @@ import Data.Ratio
import Data.Monoid (Monoid, Any(..), Sum(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Handler.Utils.Rating hiding (extractRatings)
import Handler.Utils
import qualified Handler.Utils.Rating as Rating (extractRatings)
import Handler.Utils.Zip
import Handler.Utils.Sheet
import Handler.Utils.Submission.TH
import Handler.Utils.Delete
import qualified Database.Esqueleto as E
@ -601,3 +601,40 @@ submissionMatchesSheet tid ssh csh shn cid = do
Submission{..} <- get404 sid
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
return sid
submissionDeleteRoute :: Set SubmissionId -> DeleteRoute Submission
submissionDeleteRoute drRecords = DeleteRoute
{ drRecords
, drUnjoin = \(submission `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> submission
, drGetInfo = \(submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
let lastEdit = E.sub_select . E.from $ \submissionEdit -> do
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.limit 1
return $ submissionEdit E.^. SubmissionEditTime
E.orderBy [E.desc lastEdit]
return (submission E.^. SubmissionId, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
, drRenderRecord = \(E.Value subId', E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> do
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
return [whamlet|
$newline never
<ul .list--comma-separated .list--inline .list--iconless>
$forall (dName, sName) <- subNames
<li>^{nameWidget dName sName}
&nbsp;(_{ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}, #{shn'})
|]
, drRecordConfirmString = \(E.Value subId', E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> do
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
let subNames' = Text.intercalate ", " subNames
return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
, drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
, drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
, drAbort = error "drAbort undefined"
, drSuccess = error "drSuccess undefined"
}

5
src/Handler/Utils/Table/Pagination.hs
View File

@ -471,7 +471,10 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do
return . (res,) $ do
btnId <- newIdent
act <- traverse toTextUrl dbParamsFormAction
let submitField = buttonField BtnSubmit
let submitField :: Field Handler SubmitButton
submitField = buttonField BtnSubmit
submitView :: Widget
submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False
enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
$(widgetFile "table/form-wrap")

1
src/Jobs.hs
View File

@ -57,6 +57,7 @@ import Jobs.Handler.SendTestEmail
import Jobs.Handler.QueueNotification
import Jobs.Handler.HelpRequest
import Jobs.Handler.SetLogSettings
import Jobs.Handler.DistributeCorrections
data JobQueueException = JInvalid QueuedJobId QueuedJob

9
src/Jobs/Crontab.hs
View File

@ -71,6 +71,15 @@ determineCrontab = execWriterT $ do
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
when sheetAutoDistribute $
tell $ HashMap.singleton
(JobCtlQueue $ JobDistributeCorrections nSheet)
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
, cronRepeat = CronRepeatNever
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
, cronNotAfter = Left nominalDay
}
sheetSubmissions <- lift $ collateSubmissions <$>
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []

21
src/Jobs/Handler/DistributeCorrections.hs Normal file
View File

@ -0,0 +1,21 @@
module Jobs.Handler.DistributeCorrections
( dispatchJobDistributeCorrections
) where
import Import
import Jobs.Queue
import Control.Monad.Trans.Reader (mapReaderT)
import Handler.Utils.Submission
import qualified Data.Set as Set
dispatchJobDistributeCorrections :: SheetId
-> Handler ()
dispatchJobDistributeCorrections jSheet = runDBJobs $ do
(_, unassigned) <- mapReaderT lift $ assignSubmissions jSheet Nothing
unless (Set.null unassigned) $
queueDBJob . JobQueueNotification $ NotificationCorrectionsNotDistributed jSheet

52
src/Jobs/Handler/QueueNotification.hs
View File

@ -22,26 +22,37 @@ dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
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] []
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] []
determineNotificationCandidates NotificationCorrectionsNotDistributed{nSheet}
= 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
classifyNotification :: Notification -> DB NotificationTrigger
classifyNotification NotificationSubmissionRated{..} = do
@ -53,5 +64,6 @@ classifyNotification NotificationSheetActive{} = return NTSheetActive
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed

1
src/Jobs/Handler/SendNotification.hs
View File

@ -11,6 +11,7 @@ import Jobs.Handler.SendNotification.SubmissionRated
import Jobs.Handler.SendNotification.SheetActive
import Jobs.Handler.SendNotification.SheetInactive
import Jobs.Handler.SendNotification.CorrectionsAssigned
import Jobs.Handler.SendNotification.CorrectionsNotDistributed
dispatchJobSendNotification :: UserId -> Notification -> Handler ()

2
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -22,7 +22,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

31
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs Normal file
View File

@ -0,0 +1,31 @@
module Jobs.Handler.SendNotification.CorrectionsNotDistributed
( dispatchNotificationCorrectionsNotDistributed
) where
import Import
import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet
, SubmissionRatingBy ==. Nothing
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/correctionsUndistributed.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

1
src/Jobs/Queue.hs
View File

@ -3,6 +3,7 @@ module Jobs.Queue
, queueJob, queueJob'
, YesodJobDB
, runDBJobs, queueDBJob
, module Jobs.Types
) where
import Import

2
src/Jobs/Types.hs
View File

@ -19,12 +19,14 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
, jRequestTime :: UTCTime
, jHelpRequest :: Text, jReferer :: Maybe Text }
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
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 }
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Hashable Job

2
src/Model/Types.hs
View File

@ -574,6 +574,7 @@ data NotificationTrigger = NTSubmissionRatedGraded
| NTSheetSoonInactive
| NTSheetInactive
| NTCorrectionsAssigned
| NTCorrectionsNotDistributed
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe NotificationTrigger
@ -604,6 +605,7 @@ instance Default NotificationSettings where
NTSheetSoonInactive -> False
NTSheetInactive -> True
NTCorrectionsAssigned -> True
NTCorrectionsNotDistributed -> True
instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

14
src/Utils.hs
View File

@ -542,6 +542,20 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
data GlobalPostParam = PostDeleteTarget
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam
instance Finite GlobalPostParam
nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
---------------------------------
-- Custom HTTP Request-Headers --
---------------------------------

126
src/Utils/Form.hs
View File

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Utils.Form where
import ClassyPrelude.Yesod hiding (addMessage)
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
import Settings
import qualified Text.Blaze.Internal as Blaze (null)
@ -19,13 +21,16 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.List ((!!))
import Control.Lens ((&))
import Control.Lens
import Web.PathPieces
import Data.UUID
import Utils.Message
import Utils.PathPiece
import Data.Proxy
-------------------
-- Form Renderer --
@ -36,7 +41,7 @@ data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
(res, ($ []) -> views) <- aFormToForm aform
(res, ($ []) -> fieldViews) <- aFormToForm aform
let widget = $(widgetFile "widgets/form")
return (res, widget)
@ -204,38 +209,60 @@ class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
label :: a -> WidgetT site IO ()
label = toWidget . toPathPiece
btnValidate :: forall p. p site -> a -> Bool
btnValidate _ _ = True
cssClass :: a -> ButtonCssClass site
data ButtonMessage = MsgAmbiguousButtons
| MsgWrongButtonValue
| MsgMultipleButtonValues
data SubmitButton = BtnSubmit
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece SubmitButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe SubmitButton
instance Finite SubmitButton
buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
buttonField :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, Monad m
) => a -> Field m a
-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field{..}
where
fieldEnctype = UrlEncoded
fieldView :: FieldViewFunc m a
fieldView fid name attrs _val _ = let
cssClass' :: ButtonCssClass site
cssClass' :: ButtonCssClass (HandlerSite m)
cssClass' = cssClass btn
validate = btnValidate (Proxy @(HandlerSite m)) btn
in [whamlet|
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
$newline never
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{label btn}
|]
fieldParse [] _ = return $ Right Nothing
fieldParse [str] _
| str == toPathPiece btn = return $ Right $ Just btn
| otherwise = return $ Left "Wrong button value"
fieldParse _ _ = return $ Left "Multiple button values"
fieldParse [] [] = return $ Right Nothing
fieldParse [str] []
| str == toPathPiece btn = return . Right $ Just btn
| otherwise = return . Left $ SomeMessage MsgWrongButtonValue
fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonField bs FieldSettings{..} = formToAForm $ do
mr <- getMessageRender
fvId <- maybe newIdent return fsId
name <- maybe newIdent return fsName
fvId <- maybe newFormIdent return fsId
name <- maybe newFormIdent return fsName
(ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b
, fsName = Just $ name <> "__" <> toPathPiece b
}) Nothing
@ -250,14 +277,46 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do
}
)
combinedButtonFieldF :: forall site a. (Button site a, Show (ButtonCssClass site), Finite a) => FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
combinedButtonFieldF :: forall m a.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, Finite a
, MonadHandler m
) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonFieldF = combinedButtonField (universeF :: [a])
submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
submitButton = void $ combinedButtonField [BtnSubmit] ""
disambiguateButtons :: forall m a.
( MonadHandler m
, RenderMessage (HandlerSite m) ButtonMessage
) => AForm m [Maybe a] -> AForm m a
disambiguateButtons = traverseAForm $ \case
(catMaybes -> [bRes]) -> return $ FormSuccess bRes
(catMaybes -> [] ) -> return FormMissing
_other -> formFailure [MsgAmbiguousButtons]
autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing
combinedButtonField_ :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonField_ bs fs = void . disambiguateButtons $ combinedButtonField bs fs
combinedButtonFieldF_ :: forall m a p.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
, Finite a
) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonFieldF_ _ fs = void . disambiguateButtons $ combinedButtonFieldF @m @a fs
submitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @SubmitButton) ""
autosubmitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @SubmitButton) $ "" & addAutosubmit
-------------------
-- Custom Fields --
@ -331,6 +390,27 @@ optionsFinite = do
-- Form evaluation --
---------------------
traverseAForm :: forall m a b. Monad m => (a -> m (FormResult b)) -> (AForm m a -> AForm m b)
traverseAForm adj (AForm f) = AForm $ \mr env ints -> do
ret@(res, _, _, _) <- f mr env ints
case res of
FormFailure errs
-> return $ ret & _1 .~ FormFailure errs
FormMissing
-> return $ ret & _1 .~ FormMissing
FormSuccess a -> do
a' <- adj a
return $ ret & _1 .~ a'
formFailure :: forall msg m a.
( MonadHandler m
, RenderMessage (HandlerSite m) msg
) => [msg] -> m (FormResult a)
formFailure errs' = do
mr <- getMessageRender
return . FormFailure $ map mr errs'
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x

12
templates/default-layout.lucius
View File

@ -439,6 +439,18 @@ input[type="button"].btn-info:hover,
}
.list--inline {
ul {
display: inline-block;
margin-left: 0;
li {
display: inline-block;
}
}
}
ul.list--inline {
display: inline-block;
margin-left: 0;

17
templates/mail/correctionsUndistributed.hamlet Normal file
View File

@ -0,0 +1,17 @@
$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>
_{MsgMailSubmissionsUnassignedIntro nbrSubs (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SSubsR}>
#{sheetName}

2
templates/table/form-wrap.hamlet
View File

@ -2,4 +2,4 @@ $newline never
<form method=#{decodeUtf8 (renderStdMethod dbParamsFormMethod)} action=#{fromMaybe "" act} *{dbParamsFormAttrs} enctype=#{enctype'}>
^{fWidget}
$if dbParamsFormAddSubmit
^{fieldView submitField btnId "" mempty (Right BtnSubmit) False}
^{submitView}

2
templates/widgets/delete-confirmation.hamlet
View File

@ -1,6 +1,6 @@
<p>_{drCaption}
<ul>
$forall (wdgt, _) <- sTargets
$forall (wdgt, _) <- targets
<li>
^{wdgt}

4
templates/widgets/form.hamlet
View File

@ -2,10 +2,10 @@ $newline never
#{fragment}
$case formLayout
$of FormDBTablePagesize
$forall view <- views
$forall view <- fieldViews
^{fvInput view}
$of _
$forall view <- views
$forall view <- fieldViews
$# TODO: add class 'form-group--submit' if this is the submit-button view
<div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
$if not (Blaze.null $ fvLabel view)

2
templates/widgets/form.julius
View File

@ -77,7 +77,7 @@ document.addEventListener('setup', function(e) {
var forms = e.detail.scope.querySelectorAll('form');
Array.from(forms).forEach(function(form) {
// auto reactiveButton submit-buttons with required fields
var submitBtns = Array.from(form.querySelectorAll('[type=submit]'));
var submitBtns = Array.from(form.querySelectorAll('[type=submit]:not([formnovalidate])'));
submitBtns.forEach(function(submitBtn) {
window.utils.reactiveButton(form, submitBtn, validateForm);
});

7
test/Database.hs
View File

@ -237,11 +237,11 @@ fillDb = do
void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp
void . insert $ Lecturer gkleen ffp
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
insert_ $ SheetEdit gkleen now adhoc
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
insert_ $ SheetEdit gkleen now feste
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
insert_ $ SheetEdit gkleen now keine
-- EIP
eip <- insert' Course
@ -330,6 +330,7 @@ fillDb = do
, sheetUploadMode = Upload True
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
, sheetAutoDistribute = True
}
void . insert $ SheetEdit jost now sh1
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do