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

messages/button/de.msg

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

messages/dummy/de.msg

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

messages/uniworx/de.msg

@@ -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"}
+SheetGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Blatt" "Blätter"}
-SubmissionGradingSummaryTitle count@Integer: #{display count} #{pluralDE count "Abgabe" "Abgaben"}
+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}"

models/sheets

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

src/Auth/Dummy.hs

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

src/Auth/LDAP.hs

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

src/Auth/PWHash.hs

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

src/Foundation.hs

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

src/Handler/Corrections.hs

@@ -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
+instance Universe ActionCorrections
-  renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
+instance Finite ActionCorrections
-  renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
+
-  renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
+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 -> _

src/Handler/Course.hs

@@ -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
+  deleteR $ (courseDeleteRoute $ Set.singleton cId)
-    { drRecords = Set.singleton cId
+    { drAbort = SomeRoute $ CourseR tid ssh csh CShowR
-    , drRenderRecord = \(Entity _ Course{courseName, courseTerm, courseSchool}) -> do
+    , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
-        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
     }
-{- 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

src/Handler/Profile.hs

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

src/Handler/Sheet.hs

@@ -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
+  deleteR $ (sheetDeleteRoute $ Set.singleton sid)
-    { drRecords = Set.singleton sid
+    { drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
-    , 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
     , 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
+  return ( (,) <$> autoDistributeRes <*> corrResults
-                       , FieldView
+         , [ autoDistributeView
-                           { fvLabel = text $ mr MsgCorrectors
+           , countTutView
-                           , fvTooltip = Nothing
+           , FieldView
-                           , fvId = ""
+             { fvLabel = text $ mr MsgCorrectors
-                           , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
+             , fvTooltip = Nothing
-                           , fvErrors = Nothing
+             , fvId = ""
-                           , fvRequired = True
+             , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
-                           }
+             , fvErrors = Nothing
-                       , addTutView
+             , fvRequired = True
-                           { fvInput = [whamlet|
+             }
-                               <div>
+           , addTutView
-                                 ^{fvInput addTutView}
+             { fvInput = [whamlet|
-                                 <button type=submit formnovalidate data-formnorequired>Hinzufügen
+                           <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

src/Handler/Submission.hs

@@ -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
+  deleteR $ (submissionDeleteRoute $ Set.singleton subId)
-    { drRecords = Set.singleton subId
+    { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
-    , 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
     , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
     }

src/Handler/Utils/Course.hs

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

src/Handler/Utils/Delete.hs

@@ -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
+  , drUnjoin :: tables -> E.SqlExpr (Entity record)
-  , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
+  , 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
+confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
-deleteR DeleteRoute{..} = do
+confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
-  targets <- runDB . mconcatForM drRecords $ \rKey -> do
+  where
-    ent <- Entity rKey <$> get404 rKey
+    addDeleteTargets :: Form a -> Form a
-    recordWdgt <- drRenderRecord ent
+    addDeleteTargets form csrf = do
-    recordConfirmString <- drRecordConfirmString ent
+      (_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
-    return $ pure (recordWdgt, recordConfirmString)
+      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
+postDeleteR :: ( DeleteCascade record SqlBackend )
-      confirmString = Text.unlines $ map (Text.strip . view _2) sTargets
+            => (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys
-      confirmField
+            -> Handler ()
-        | Set.size drRecords <= 1 = textField
+-- | Perform deletion
-        | otherwise = convertField unTextarea Textarea textareaField
+postDeleteR mkRoute = do
-  
+  drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget
-  ((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,)
-    <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
-    <*> combinedButtonFieldF ""
 
-  formResult deleteFormRes $ \case
+  void . for drResult $ \DeleteRoute{..} -> do
-    (_, catMaybes -> [BtnAbort]) ->
+    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))
-      redirect drAbort
+
-    (inpConfirmStr, catMaybes -> [BtnDelete])
+    ((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
-      | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
+
-        -> do
+    formResult confirmRes $ \case
-          runDB $ do
+      True -> do
-            forM_ drRecords deleteCascade
+        runDB $ do
-            addMessageI Success drSuccessMessage
+          forM_ drRecords deleteCascade
-          redirect drSuccess
+          addMessageI Success drSuccessMessage
-      | otherwise
+        redirect drSuccess
-        -> addMessageI Error MsgDeleteConfirmationWrong
+      False ->
-    _other -> return ()
+        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
+  sendResponse =<<
-    $(widgetFile "widgets/delete-confirmation")
+    defaultLayout $(widgetFile "widgets/delete-confirmation")
+
+
+
+deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html
+deleteR dr = do
+  postDeleteR $ \drRecords -> dr {drRecords}
+  getDeleteR dr

src/Handler/Utils/Form.hs

@@ -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
+nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
 
 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
+instance Universe RegisterButton
-  toPathPiece   = showToPathPiece
+instance Finite RegisterButton
-  fromPathPiece = readFromPathPiece
+
+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
+instance Universe AdminHijackUserButton
-  toPathPiece   = showToPathPiece
+instance Finite AdminHijackUserButton
-  fromPathPiece = readFromPathPiece
+
+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.)

src/Handler/Utils/Sheet.hs

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

src/Handler/Utils/Submission.hs

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

src/Handler/Utils/Table/Pagination.hs

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

src/Jobs.hs

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

src/Jobs/Crontab.hs

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

src/Jobs/Handler/DistributeCorrections.hs

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

src/Jobs/Handler/QueueNotification.hs

@@ -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
+determineNotificationCandidates NotificationSubmissionRated{..}
-  E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
+  = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
-  E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
+      E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
-  return user
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
-determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+      return user
-  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+determineNotificationCandidates NotificationSheetActive{..}
-  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+  = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
-  return user
+      E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
-determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
-  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+      return user
-  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+determineNotificationCandidates NotificationSheetSoonInactive{..}
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+  = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
-  return user
+      E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
-determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do  
+      E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
-  E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse 
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
-  E.on $ lecturer E.^. LecturerUser   E.==. user E.^. UserId
+      return user
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+determineNotificationCandidates NotificationSheetInactive{..}
-  return user
+  = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do  
-determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] [] 
+      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
 
 

src/Jobs/Handler/SendNotification.hs

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

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

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

src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs

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

src/Jobs/Queue.hs

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

src/Jobs/Types.hs

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

src/Model/Types.hs

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

src/Utils.hs

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

src/Utils/Form.hs

@@ -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
+instance Universe SubmitButton
-  toPathPiece   = showToPathPiece
+instance Finite SubmitButton
-  fromPathPiece = readFromPathPiece
 
-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)
+nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
-buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
+
+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 []    [] = return $ Right Nothing
-    fieldParse [str] _
+    fieldParse [str] []
-      | str == toPathPiece btn = return $ Right $ Just btn
+      | str == toPathPiece btn = return . Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value"
+      | otherwise  = return . Left $ SomeMessage MsgWrongButtonValue
-    fieldParse _ _ = return $ Left "Multiple button values"
+    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
+  fvId <- maybe newFormIdent return fsId
-  name <- maybe newIdent return fsName
+  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) ()
+disambiguateButtons :: forall m a.
-submitButton = void $ combinedButtonField [BtnSubmit] ""
+                     ( 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) ()
+combinedButtonField_ :: forall a m.
-autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing
+                      ( 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
 

templates/default-layout.lucius

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

templates/mail/correctionsUndistributed.hamlet

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

templates/table/form-wrap.hamlet

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

templates/widgets/delete-confirmation.hamlet

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

templates/widgets/form.hamlet

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

templates/widgets/form.julius

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

test/Database.hs

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