From 92600246761cf1029787805bcfc07c2df3bdeeb8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 28 May 2018 16:41:47 +0200 Subject: [PATCH] Replace SheetCorrectors --- messages/de.msg | 10 ++++- models | 1 + package.yaml | 1 + src/Foundation.hs | 1 + src/Handler/Sheet.hs | 79 ++++++++++++++++++++++++++++++--------- src/Handler/Utils/Form.hs | 2 +- src/Model/Types.hs | 2 +- 7 files changed, 76 insertions(+), 20 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 2a20f9bf6..15f357010 100644 --- a/messages/de.msg +++ b/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} \ No newline at end of file +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 \ No newline at end of file diff --git a/models b/models index ce5229b24..e9f9246da 100644 --- a/models +++ b/models @@ -118,6 +118,7 @@ SheetCorrector sheet SheetId load Load UniqueSheetCorrector user sheet + deriving Show Eq Ord SheetFile sheet SheetId file FileId diff --git a/package.yaml b/package.yaml index bb217ec2b..ccfb37678 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index c2861c77f..228d92f4f 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 44e3734cc..0b86114e8 100644 --- a/src/Handler/Sheet.hs +++ b/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 + + + $forall E.Value prev <- previousCorrectors +