diff --git a/messages/de.msg b/messages/de.msg index d296157b4..2a20f9bf6 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -39,3 +39,6 @@ SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet. +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 diff --git a/routes b/routes index c04ca7ada..8dc1ec910 100644 --- a/routes +++ b/routes @@ -21,13 +21,14 @@ /edit CourseEditR GET POST !lecturer /ex SheetR !registered: - / SheetListR GET - /#Text/show SheetShowR GET !time - /#Text/#SheetFileType/#FilePath SheetFileR GET !time - /new SheetNewR GET POST !lecturer - /#Text/edit SheetEditR GET POST !lecturer - /#Text/delete SheetDelR GET POST !lecturer - !/#Text/submission/#SubmissionMode SubmissionR GET POST !time + / SheetListR GET + /#Text/show SheetShowR GET !time + /#Text/#SheetFileType/#FilePath SheetFileR GET !time + /new SheetNewR GET POST !lecturer + /#Text/edit SheetEditR GET POST !lecturer + /#Text/delete SheetDelR GET POST !lecturer + /#Text/correctors SheetCorrectorsR GET POST !lecturer + !/#Text/submission/#SubmissionMode SubmissionR GET POST !time !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET diff --git a/src/Foundation.hs b/src/Foundation.hs index 659b00513..c2861c77f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -331,6 +331,7 @@ isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAcce isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID +isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseEditIDR cID) _ = do courseId <- decrypt cID courseLecturerAccess courseId @@ -453,6 +454,12 @@ pageActions (CSheetR tid csh (SheetShowR shn)) = , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission) , menuItemAccessCallback' = return True } + , PageActionPrime $ MenuItem + { menuItemLabel = "Korrektoren" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh (SheetCorrectorsR shn) + , menuItemAccessCallback' = return True + } ] pageActions TermShowR = [ PageActionPrime $ MenuItem diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8f3d895cb..44e3734cc 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -8,6 +8,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} module Handler.Sheet where @@ -31,11 +33,20 @@ 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 qualified Data.List as List import Network.Mime import qualified Data.Set as Set +import Data.Map (Map, (!), (!?)) +import qualified Data.Map as Map + +import Control.Lens +import Utils.Lens + instance Eq (Unique Sheet) where (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = @@ -62,7 +73,6 @@ data SheetForm = SheetForm , sfSolutionFrom :: Maybe UTCTime , sfSolutionF :: Maybe FileInfo -- Keine SheetId im Formular! - , sfCorrectors :: [(UserId,Load)] } @@ -90,8 +100,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <*> fileAFormOpt (fsb "Hinweis") <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) <*> fileAFormOpt (fsb "Lösung") - <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template)) - -- <* submitButton + <* submitButton return $ case result of FormSuccess sheetResult | errorMsgs <- validateSheet sheetResult @@ -120,14 +129,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do -- TODO: continue validation here!!! ] ] -correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX]) -correctorForm _msid templates = do undefined - -- Datenbank UserId -> UserName - -- Eingabelist für Colonnade - -- enthält die benötigten Felder - -- FormResult konstruieren - -- Eingabebox für Korrektor hinzufügen - -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -- List Sheets @@ -298,7 +299,6 @@ getSheetEditR tid csh shn = do , sfHintF = Nothing -- TODO , sfSolutionFrom = sheetSolutionFrom , sfSolutionF = Nothing -- TODO - , sfCorrectors = [] -- TODO read correctors from list } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet @@ -407,3 +407,132 @@ insertSheetFile' sid ftype fs = do finsert (Right file) = lift $ do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step + + +data CorrectorForm = CorrectorForm + { cfUserId :: UserId + , cfUserName :: Text + , cfResult :: FormResult Load + , cfViewByTut, cfViewCountTut, cfViewProp :: FieldView UniWorX + } + +type Loads = Map UserId Load + +defaultLoads :: SheetId -> DB Loads +-- ^ Generate `Loads` in such a way that minimal editing is required +-- +-- For every user, that ever was a corrector for this course, return their last `Load`. +-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit). +defaultLoads shid = fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + + let creationTime = E.sub_select . E.from $ \sheetEdit -> do + E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId + return . E.min_ $ sheetEdit E.^. SheetEditTime + + E.orderBy [E.desc creationTime] + + return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad) + where + toMap :: [(E.Value UserId, E.Value Load)] -> Loads + toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load + + +correctorForm :: SheetId -> MForm Handler (FormResult Loads, [FieldView UniWorX]) +correctorForm shid = do + cListIdent <- newFormIdent + formCIDs <- lift $ mapM decrypt =<< (catMaybes . map fromPathPiece <$> lookupPostParams cListIdent :: Handler [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) + + loads <- case addTutRes of + FormSuccess (Just email) -> do + mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email) + case mUid of + Nothing -> loads' <$ addMessageI "error" (MsgEMailUnknown email) + Just uid + | not (Map.member uid loads') -> return $ Map.insert uid mempty loads' + | otherwise -> loads' <$ addMessageI "warning" (MsgCorrectorExists email) + FormFailure errs -> loads' <$ mapM_ (addMessage "error" . toHtml) errs + _ -> return loads' + + names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do + E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads) + return $ (user E.^. UserId, user E.^. UserDisplayName) + + let + constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm + constructFields (uid, uname, Load{..}) = do + cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser + let + fs name = "" + { fsName = Just $ tshow ciphertext <> "-" <> name + } + 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) + let + cfResult :: FormResult Load + cfResult = Load <$> tutRes' <*> propRes + tutRes' + | FormSuccess True <- byTutRes = Just <$> countTutRes + | otherwise = Nothing <$ byTutRes + cfUserId = uid + cfUserName = uname + return CorrectorForm{..} + + corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid + + 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 + ] + corrResults + | FormSuccess _ <- addTutRes = FormMissing + | otherwise = fmap Map.fromList $ sequenceA [ (,) <$> pure cfUserId <*> cfResult + | CorrectorForm{..} <- corrData + ] + idField CorrectorForm{..} = do + cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser + toWidget [hamlet||] + + return (corrResults, [ FieldView + { fvLabel = mempty + , fvTooltip = Nothing + , fvId = "" + , fvInput = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData + , fvErrors = Nothing + , fvRequired = True + } + , addTutView + { fvInput = fvInput addTutView >> toWidget [hamlet|