Mockup of SheetCorrectorsR
This commit is contained in:
Gregor Kleen
parent
d70781659e
commit
30b941eeec
@ -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}
|
||||
15
routes
15
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
|
||||
|
||||
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|<button type=submit formnovalidate>Hinzufügen|]
|
||||
}
|
||||
])
|
||||
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
getSheetCorrectorsR, postSheetCorrectorsR :: TermId
|
||||
-> Text -- ^ Course shorthand
|
||||
-> Text -- ^ Sheet name
|
||||
-> Handler Html
|
||||
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
|
||||
|
||||
let
|
||||
formTitle = MsgSheetCorrectorsTitle tident csh shn
|
||||
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
||||
actionUrl = CSheetR tid csh $ SheetCorrectorsR shn
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetCorrectorsTitle tident csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
Loading…
Reference in New Issue
Block a user