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

Fix behaviour of correctors-form

Browse Source
This commit is contained in:
Gregor Kleen 2018-06-29 11:49:03 +02:00
parent 6e0558d094
commit 9793141090
2 changed files with 52 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/de.msg
View File

@ -87,6 +87,7 @@ DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
CorrectorsPlaceholder: Korrektoren...
CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
HomeHeading: Aktuelle Termine
ProfileHeading: Benutzerprofil und Einstellungen

78
src/Handler/Sheet.hs
View File

@ -11,6 +11,8 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Handler.Sheet where
@ -24,7 +26,7 @@ import Handler.Utils.Zip
import qualified Data.Text as T
-- import Data.Function ((&))
--
import Colonnade hiding (fromMaybe, singleton)
import Colonnade hiding (fromMaybe, singleton, bool)
import Yesod.Colonnade
import Text.Blaze (text)
--
@ -106,7 +108,6 @@ 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
return $ case result of
FormSuccess sheetResult
@ -431,16 +432,20 @@ defaultLoads :: SheetId -> DB Loads
--
-- 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
defaultLoads shid = do
cId <- sheetCourse <$> getJust 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
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]
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
E.orderBy [E.desc creationTime]
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
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
@ -450,17 +455,27 @@ correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [Fie
correctorForm shid = do
cListIdent <- newFormIdent
let
guardNonDeleted :: CryptoUUIDUser -> Handler (Maybe CryptoUUIDUser)
guardNonDeleted cID@CryptoID{..} = do
guardNonDeleted :: UserId -> Handler (Maybe UserId)
guardNonDeleted uid = do
cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
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]
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) Nothing
return $ bool Just (const Nothing) (isJust deleted) uid
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
let
currentLoads :: DB Loads
currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
| otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
didDelete = any (flip Set.member deletions) formCIDs
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
let
tutorField :: Field Handler [Text]
tutorField = multiEmailField
@ -488,12 +503,14 @@ correctorForm shid = 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)
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'
| 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''
let deletions' = deletions `Set.difference` Map.keysSet 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)
@ -526,6 +543,8 @@ correctorForm shid = do
mr <- getMessageRender
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
let
corrColonnade = mconcat
[ headed (textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> textCell cfUserName
@ -536,6 +555,7 @@ correctorForm shid = do
corrResults
| FormSuccess (Just es) <- addTutRes
, not $ null es = FormMissing
| didDelete = FormMissing
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
| CorrectorForm{..} <- corrData
]
@ -543,12 +563,16 @@ correctorForm shid = do
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
delField uid = 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 = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData
, fvInput = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
, fvErrors = Nothing
, fvRequired = True
}
@ -585,8 +609,8 @@ getSCorrR tid@(unTermKey -> tident) csh shn = do
let
formTitle = MsgSheetCorrectorsTitle tident csh shn
formText = Nothing :: Maybe (SomeMessage UniWorX)
-- actionUrl = CSheetR tid csh shn SCorrR
actionUrl = CSheetR tid csh shn SShowR
actionUrl = CSheetR tid csh shn SCorrR
-- actionUrl = CSheetR tid csh shn SShowR
defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tident csh shn
$(widgetFile "formPageI18n")