Replace SheetCorrectors

messages/de.msg

@@ -41,4 +41,12 @@ NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs
 
 AddCorrector: Zusätzlicher Korrektor
 CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
-SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName}
+SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName}
+CountTutProp: Tutorien zählen gegen Proportion
+Corrector: Korrektor
+Correctors: Korrektoren
+CorByTut: Nach Tutorium
+CorProportion: Anteil
+DeleteRow: Zeile entfernen
+ProportionNegative: Anteile dürfen nicht negativ sein
+CorrectorsUpdated: Korrektoren erfolgreich aktualisiert

models

@@ -118,6 +118,7 @@ SheetCorrector
     sheet           SheetId
     load            Load
     UniqueSheetCorrector user sheet
+    deriving Show Eq Ord
 SheetFile
     sheet           SheetId
     file            FileId

package.yaml

@@ -81,6 +81,7 @@ dependencies:
 - exceptions
 - lens
 - MonadRandom
+- email-validate
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -414,6 +414,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn,      Just $ CourseR tid csh $ SheetR SheetListR)
   breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit",   Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
   breadcrumb (CourseR tid csh (SheetR (SheetDelR  shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
+  breadcrumb (CourseR tid csh (SheetR (SheetCorrectorsR shn))) = return ("Korrektoren", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
   breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
 
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)

src/Handler/Sheet.hs

@@ -25,6 +25,7 @@ import qualified Data.Text as T
 -- 
 import Colonnade hiding (fromMaybe, singleton)
 import Yesod.Colonnade
+import Text.Blaze (text)
 -- 
 import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
@@ -33,12 +34,15 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
 import Control.Monad.Writer (MonadWriter(..), execWriterT)
-import Control.Monad.Trans.RWS.Lazy (RWST)
+import Control.Monad.Trans.RWS.Lazy (RWST, local)
+
+import qualified Text.Email.Validate as Email
 
 import qualified Data.List as List
 
 import Network.Mime
 
+import Data.Set (Set)
 import qualified Data.Set as Set
 
 import Data.Map (Map, (!), (!?))
@@ -413,7 +417,7 @@ data CorrectorForm = CorrectorForm
   { cfUserId :: UserId
   , cfUserName :: Text
   , cfResult :: FormResult Load
-  , cfViewByTut, cfViewCountTut, cfViewProp :: FieldView UniWorX
+  , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
   }
 
 type Loads = Map UserId Load
@@ -438,17 +442,46 @@ defaultLoads shid = fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheet
     toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
 
 
-correctorForm :: SheetId -> MForm Handler (FormResult Loads, [FieldView UniWorX])
+correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
 correctorForm shid = do
   cListIdent <- newFormIdent
-  formCIDs <- lift $ mapM decrypt =<< (catMaybes . map fromPathPiece <$> lookupPostParams cListIdent :: Handler [CryptoUUIDUser])
+  let
+    guardNonDeleted :: CryptoUUIDUser -> Handler (Maybe CryptoUUIDUser)
+    guardNonDeleted cID@CryptoID{..} = do
+      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
+      case deleted of
+        Just _  -> return Nothing
+        Nothing -> return $ Just cID
+  formCIDs <- lift $ (mapM decrypt <=< fmap catMaybes . mapM (maybe (return Nothing) guardNonDeleted)) =<< (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
   loads'' <- lift . runDB $ defaultLoads shid
   let loads' = loads'' `Map.union` Map.fromList [(uid, mempty) | uid <- formCIDs]
   
-  (addTutRes, addTutView) <- mopt emailField (fsm MsgAddCorrector) (Just Nothing)
+  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) Nothing
+  let
+    tutorField :: Field Handler [Text]
+    tutorField = multiEmailField
+      { fieldView = \theId name attrs val isReq -> asWidgetT $ do
+          listIdent <- newIdent
+          userId <- handlerToWidget requireAuthId
+          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
+            E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+            E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+            E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
+            return $ user E.^. UserEmail
+          toWidget [hamlet|
+            $newline never
+            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="">
+            <datalist id=#{listIdent}>
+              $forall E.Value prev <- previousCorrectors
+                <option value=#{prev}>
+          |]
+      }
+  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
 
   loads <- case addTutRes of
-    FormSuccess (Just email) -> do
+    FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
       mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
       case mUid of
         Nothing  -> loads' <$ addMessageI "error" (MsgEMailUnknown email)
@@ -473,8 +506,8 @@ correctorForm shid = do
         rationalField = convertField toRational fromRational doubleField
 
       (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
-      (countTutRes, cfViewCountTut) <- mreq checkBoxField (fs "counttut") byTutorial
-      (propRes, cfViewProp) <- mreq rationalField (fs "prop") (Just byProportion)
+      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
+      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
       let
         cfResult :: FormResult Load
         cfResult = Load <$> tutRes' <*> propRes
@@ -487,24 +520,28 @@ correctorForm shid = do
 
   corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
 
+  mr <- getMessageRender
+
   let
     corrColonnade = mconcat
-      [ headed "Korrektor" $ \CorrectorForm{..} -> textCell cfUserName
-      , headed "Nach Tutorium" $ \CorrectorForm{..} -> cell $ fvInput cfViewByTut
-      , headed "Tutorium zählt gegen Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewCountTut -- TODO: set this once for entire sheet?
-      , headed "Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewProp
+      [ headed (textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> textCell cfUserName
+      , headed (textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> cell $ fvInput cfViewByTut
+      , headed (textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> cell $ fvInput cfViewProp
+      , headed (textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> cell $ fvInput cfViewDel
       ]
     corrResults
-      | FormSuccess _ <- addTutRes = FormMissing
-      | otherwise = fmap Map.fromList $ sequenceA [ (,) <$> pure cfUserId <*> cfResult
+      | FormSuccess (Just es) <- addTutRes
+      , not $ null es = FormMissing
+      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
                                                   | CorrectorForm{..} <- corrData
                                                   ]
     idField CorrectorForm{..} = do
       cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
       toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
 
-  return (corrResults, [ FieldView
-                           { fvLabel = mempty
+  return (corrResults, [ countTutView
+                       , FieldView
+                           { fvLabel = text $ mr MsgCorrectors
                            , fvTooltip = Nothing
                            , fvId = ""
                            , fvInput = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData
@@ -527,7 +564,15 @@ postSheetCorrectorsR = getSheetCorrectorsR
 getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
   Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
 
-  ((res,formWidget), formEnctype) <- runFormPost . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+  ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+
+  case res of
+    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormSuccess res -> runDB $ do
+      deleteWhere [SheetCorrectorSheet ==. shid]
+      insertMany_ $ Set.toList res
+      addMessageI "success" MsgCorrectorsUpdated
+    FormMissing -> return ()
 
   let
     formTitle = MsgSheetCorrectorsTitle tident csh shn

src/Handler/Utils/Form.hs

@@ -48,7 +48,7 @@ import Control.Monad.Writer.Class
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDcorrectors
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 

src/Model/Types.hs

@@ -82,7 +82,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
     = Load { byTutorial :: Maybe Bool  -- ^ Just all from Tutorial, True if counting towards overall workload
            , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
            }
-  deriving (Show, Read, Eq)
+  deriving (Show, Read, Eq, Ord)
 derivePersistField "Load"
 
 instance Semigroup Load where