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

Merge branch '334-urgent-sheet-corrector-table-heading' into 'master'

Browse Source 
Work on "Urgent: Sheet Corrector Table Heading"

See merge request !180
This commit is contained in:
Gregor Kleen 2019-04-20 21:46:15 +02:00
commit 01f446bcb2
26 changed files with 407 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
messages/uniworx/de.msg
View File

@ -13,6 +13,8 @@ BtnCandidatesDeleteAll: Alle Beobachtungen löschen
BtnResetTokens: Authorisierungs-Tokens invalidieren
BtnLecInvAccept: Annehmen
BtnLecInvDecline: Ablehnen
BtnCorrInvAccept: Annehmen
BtnCorrInvDecline: Ablehnen
Aborted: Abgebrochen
Remarks: Hinweise
@ -253,7 +255,7 @@ NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nic
TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
AddCorrector: Zusätzlicher Korrektor
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
CorrectorExists: Nutzer ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion
AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen
@ -533,7 +535,9 @@ MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
CommCourseSubject: Kursmitteilung
MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen
InvitationAcceptDecline: Einladung annehmen/ablehnen
MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
@ -753,7 +757,7 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "
DeleteConfirmation: Bestätigung
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
MassInputAddDimension: Hinzufügen
MassInputDeleteCell: Entfernen
@ -763,7 +767,7 @@ NavigationFavourites: Favoriten
CommSubject: Betreff
CommBody: Nachricht
CommRecipients: Empfänger
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht.
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
@ -776,10 +780,15 @@ RGCourseLecturers: Kursverwalter
RGCourseCorrectors: Korrektoren
MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
MultiEmailFieldTip: Je nach Browser sind mehrere komma-separierte E-Mail-Addressen möglich
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen
CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.

7
models/sheets
View File

@ -36,6 +36,13 @@ SheetCorrector -- grant corrector role to user for a sheet
state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
UniqueSheetCorrector user sheet
deriving Show Eq Ord
SheetCorrectorInvitation json
email UserEmail
sheet SheetId
load Load
state CorrectorState
UniqueSheetCorrectorInvitation email sheet
deriving Show Read Eq Ord Generic Typeable
SheetFile -- a file that is part of an exercise sheet
sheet SheetId
file FileId

1
routes
View File

@ -104,6 +104,7 @@
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions
/corrector-invite/#UserEmail SCorrInviteR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector

1
src/Handler/Course.hs
View File

@ -545,6 +545,7 @@ courseEditHandler miButtonAction mbCourseForm = do
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
deleteWhere [LecturerCourse ==. cid]
deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
forM_ (cfLecturers res) $ \case
Right (lid, lty) -> insert_ $ Lecturer lid cid lty
Left (lEmail, mLTy) -> do

305
src/Handler/Sheet.hs
View File

@ -1,6 +1,9 @@
module Handler.Sheet where
import Import
import Jobs.Queue
import System.FilePath (takeFileName)
import Utils.Sheet
@ -9,20 +12,19 @@ import Handler.Utils
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
import Handler.Utils.Delete
import Handler.Utils.Form.MassInput
-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
--
-- import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod
import Text.Blaze (text)
--
-- import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C
-- import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
-- import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E
-- import qualified Database.Esqueleto.Internal.Sql as E
@ -42,7 +44,7 @@ import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map (Map, (!?))
import Data.Map (Map, (!))
import Data.Monoid (Any(..))
@ -614,7 +616,7 @@ data CorrectorForm = CorrectorForm
, cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
}
type Loads = Map UserId (CorrectorState, Load)
type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)
defaultLoads :: SheetId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required
@ -637,164 +639,152 @@ defaultLoads shid = do
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
cListIdent <- newFormIdent
let
guardNonDeleted :: UserId -> Handler (Maybe UserId)
guardNonDeleted uid = do
CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
return $ bool Just (const Nothing) (isJust deleted) uid
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector))
correctorForm shid = wFormToAForm $ do
Just currentRoute <- liftHandlerT getCurrentRoute
userId <- liftHandlerT requireAuthId
MsgRenderer mr <- getMsgRenderer
let
currentLoads :: DB Loads
currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
(autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
| otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
currentLoads = Map.union
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
<*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] [])
(defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> 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'
(autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
let
tutorField :: Field Handler [UserEmail]
tutorField = convertField (map CI.mk) (map CI.original) $ 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
[whamlet|
$newline never
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
<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 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)
Just uid
| not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, 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)
return $ (user E.^. UserId, user E.^. UserDisplayName)
isWrite <- liftHandlerT $ isWriteRequest currentRoute
let
constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
constructFields (uid, uname, (state, Load{..})) = do
CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
let
fs name = ""
{ fsName = Just $ tshow ciphertext <> "-" <> name
}
rationalField = convertField toRational fromRational doubleField
applyDefaultLoads = Map.null currentLoads' && not isWrite
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
loads
| applyDefaultLoads = defaultLoads'
| otherwise = currentLoads'
(stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
when (not (Map.null loads) && applyDefaultLoads) $
addMessageI Warning MsgCorrectorsDefaulted
countTutRes <- wreq checkBoxField (fsm MsgCountTutProp) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
let
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> 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
miAdd :: ListPosition
-> Natural
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
, not $ null existing
-> FormFailure [mr MsgCorrectorExists]
| otherwise
-> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
return (addRes', $(widgetFile "sheetCorrectors/add"))
miCell :: ListPosition
-> Either UserEmail UserId
-> Maybe (CorrectorState, Load)
-> (Text -> Text)
-> Form (CorrectorState, Load)
miCell _ userIdent initRes nudge csrf = do
(stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
let
cfResult :: FormResult (CorrectorState, Load)
cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
res :: FormResult (CorrectorState, Load)
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
tutRes'
| FormSuccess True <- byTutRes = Just <$> countTutRes
| otherwise = Nothing <$ byTutRes
cfUserId = uid
cfUserName = uname
return CorrectorForm{..}
identWidget <- case userIdent of
Left email -> return . toWidget $ mailtoHtml email
Right uid -> do
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
return $ nameEmailWidget userEmail userDisplayName userSurname
return (res, $(widgetFile "sheetCorrectors/cell"))
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
miDelete :: ListLength
-> ListPosition
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
miDelete = miDeleteList
mr <- getMessageRender
miAllowAdd :: ListPosition
-> Natural
-> ListLength
-> Bool
miAllowAdd _ _ _ = True
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
miAddEmpty :: ListPosition
-> Natural
-> ListLength
-> Set ListPosition
miAddEmpty _ _ _ = Set.empty
let
corrColonnade = mconcat
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
, headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
, headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
]
corrResults
| FormSuccess (Just es) <- addTutRes
, not $ null es = FormMissing
| didDelete = FormMissing
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
| CorrectorForm{..} <- corrData
]
idField CorrectorForm{..} = do
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
miButtonAction :: forall p.
PathPiece p
=> p
-> Maybe (SomeRoute UniWorX)
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
delField uid = do
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
miLayout :: ListLength
-> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
-> Map ListPosition Widget
-> Map ListPosition (FieldView UniWorX)
-> Map (Natural, ListPosition) Widget
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
return ( (,) <$> autoDistributeRes <*> corrResults
, [ autoDistributeView
, countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
postProcess = Set.fromList . map postProcess' . Map.elems
where
sheetCorrectorSheet = shid
sheetCorrectorInvitationSheet = shid
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}
-- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
uid <- requireAuthId
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
(,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
<*> correctorForm shid
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (autoDistribute, res') -> runDB $ do
FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res'
deleteWhere [ SheetCorrectorSheet ==. shid ]
deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
forM_ sheetCorrectors $ \case
Right shCor -> insert_ shCor
Left shCorInv -> do
insertRes <- insertBy shCorInv
case insertRes of
Right _ ->
void . queueDBJob $ JobCorrectorInvitation uid shCorInv
Left (Entity old _) ->
replace old shCorInv
addMessageI Success MsgCorrectorsUpdated
FormMissing -> return ()
@ -804,3 +794,50 @@ getSCorrR tid ssh csh shn = do
{ formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR
, formEncoding = formEnctype
}
data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ButtonCorrInvite
instance Finite ButtonCorrInvite
nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''ButtonCorrInvite id
instance Button UniWorX ButtonCorrInvite where
btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html
getSCorrInviteR = postSCorrInviteR
postSCorrInviteR tid ssh csh shn email = do
uid <- requireAuthId
(Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do
(sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn
iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid
return (cRes, sRes, iRes)
((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm
let btnWidget = wrapForm btnInnerWidget def
{ formEncoding = btnEncoding
, formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email
, formSubmit = FormNoSubmit
}
formResult btnResult $ \case
BtnCorrInvAccept -> do
runDB $ do
delete ciId
insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState
addMessageI Success $ MsgCorrectorInvitationAccepted shn
redirect $ CSheetR tid ssh csh shn SShowR
BtnCorrInvDecline -> do
runDB $
delete ciId
addMessageI Info $ MsgCorrectorInvitationDeclined shn
redirect HomeR
siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do
setTitleI $ MsgSheetCorrInviteHeading shn
$(widgetFile "sheetCorrInvite")

2
src/Handler/Utils.hs
View File

@ -101,7 +101,7 @@ wrapMailto (original -> email) linkText
-- | Just show an email address in a standard way, for convenience inside hamlet files.
mailtoHtml :: UserEmail -> Html
mailtoHtml email = wrapMailto email $ toHtml email
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
-- | Generic i18n text for "edited at sometime by someone"
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget

6
src/Handler/Utils/Communication.hs
View File

@ -24,8 +24,6 @@ import qualified Data.Set as Set
import Data.Aeson.TH
import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
import Data.List (nub)
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -133,9 +131,9 @@ commR CommunicationRoute{..} = do
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq multiEmailField (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
let
addRes' = addRes <&> \(nub . map CI.mk -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) (map Left nEmails)
addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
miAdd _ _ _ _ = Nothing
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do

69
src/Handler/Utils/Form.hs
View File

@ -33,12 +33,13 @@ import Data.Map (Map, (!))
import qualified Data.Map as Map
import Control.Monad.Trans.Writer (execWriterT, WriterT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Writer.Class
import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)
import Data.Either (partitionEithers)
import Utils.Lens
@ -47,6 +48,8 @@ import Data.Aeson.Text (encodeToLazyText)
import Data.Proxy
import qualified Text.Email.Validate as Email
----------------------------
-- Buttons (new version ) --
----------------------------
@ -651,3 +654,67 @@ formResultModal res finalDest handler = maybeT_ $ do
| otherwise -> do
forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
redirect finalDest
multiUserField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Bool -- ^ Only resolve suggested users?
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
-> Field m (Set (Either UserEmail UserId))
multiUserField onlySuggested suggestions = Field{..}
where
lookupExpr
| onlySuggested = suggestions
| otherwise = Just $ E.from return
fieldEnctype = UrlEncoded
fieldView theId name attrs val isReq = do
val' <- case val of
Left t -> return t
Right vs -> Text.intercalate ", " . map CI.original <$> do
let (emails, uids) = partitionEithers $ Set.toList vs
rEmails <- case lookupExpr of
Nothing -> return []
Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
dbRes <- liftHandlerT . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserId E.==. E.val uid
return $ user E.^. UserEmail
case dbRes of
[E.Value email] -> return [email]
_other -> return []
return $ emails ++ rEmails
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
[whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|]
whenIsJust suggestions $ \suggestions' -> do
suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
user <- suggestions'
return $ user E.^. UserEmail
[whamlet|
$newline never
<datalist id=#{datalistId}>
$forall email <- suggestedEmails
<option value=#{email}>
|]
fieldParse (all Text.null -> True) _ = return $ Right Nothing
fieldParse ts _ = runExceptT . fmap Just $ do
let ts' = concatMap (Text.splitOn ",") ts
emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
Nothing -> return $ Left email
Just lookupExpr' -> do
dbRes <- liftHandlerT . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserEmail E.==. E.val email
return $ user E.^. UserId
case dbRes of
[] -> return $ Left email
[E.Value uid] -> return $ Right uid
_other -> fail "Ambiguous e-mail addr"

16
src/Handler/Utils/Form/MassInput.hs
View File

@ -6,7 +6,7 @@ module Handler.Utils.Form.MassInput
, defaultMiLayout
, massInput
, module Handler.Utils.Form.MassInput.Liveliness
, massInputA
, massInputA, massInputW
, massInputList
, ListLength(..), ListPosition(..), miDeleteList
, EnumLiveliness(..), EnumPosition(..)
@ -484,3 +484,17 @@ massInputA :: forall handler cellData cellResult liveliness.
-> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
massInputA mi fs fvRequired initialResult = formToAForm $
over _2 pure <$> massInput mi fs fvRequired initialResult mempty
massInputW :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> WForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)))
massInputW mi fs fvRequired initialResult = mFormToWForm $
massInput mi fs fvRequired initialResult mempty

13
src/Handler/Utils/Sheet.hs
View File

@ -12,7 +12,7 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, Typeable a, MonadHandler m, IsPersistBackend backend
, PersistQueryRead backend, PersistUniqueRead backend
)
=> (E.SqlExpr (Entity Sheet) -> b)
=> (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
@ -27,19 +27,22 @@ fetchSheetAux prj tid ssh csh shn =
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet
return $ prj sheet course
case sheetList of
[sheet] -> return sheet
_other -> notFound
fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id
fetchSheet = fetchSheetAux const
fetchSheetCourse :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet, Entity Course)
fetchSheetCourse = fetchSheetAux (,)
fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (\sheet _ -> sheet E.^. SheetId) tid ssh cid shn
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet

1
src/Jobs.hs
View File

@ -61,6 +61,7 @@ import Jobs.Handler.SetLogSettings
import Jobs.Handler.DistributeCorrections
import Jobs.Handler.SendCourseCommunication
import Jobs.Handler.LecturerInvitation
import Jobs.Handler.CorrectorInvitation
data JobQueueException = JInvalid QueuedJobId QueuedJob

42
src/Jobs/Handler/CorrectorInvitation.hs Normal file
View File

@ -0,0 +1,42 @@
module Jobs.Handler.CorrectorInvitation
( dispatchJobCorrectorInvitation
) where
import Import
import Text.Hamlet
import qualified Data.HashSet as HashSet
import qualified Data.CaseInsensitive as CI
import Utils.Lens
dispatchJobCorrectorInvitation :: UserId -> SheetCorrectorInvitation -> Handler ()
dispatchJobCorrectorInvitation jInviter jCorrectorInvitation@SheetCorrectorInvitation{..} = do
ctx <- runDB . runMaybeT $ do
sheet <- MaybeT $ get sheetCorrectorInvitationSheet
course <- MaybeT . get $ sheetCourse sheet
void . MaybeT $ getByValue jCorrectorInvitation
user <- MaybeT $ get jInviter
return (sheet, course, user)
case ctx of
Just (Sheet{..}, Course{..}, User{..}) -> do
let baseRoute = CSheetR courseTerm courseSchool courseShorthand sheetName $ SCorrInviteR sheetCorrectorInvitationEmail
jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
let
invitationUrl :: SomeRoute UniWorX
invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
invitationUrl' <- toTextUrl invitationUrl
mailT def $ do
_mailTo .= [Address Nothing (CI.original $ sheetCorrectorInvitationEmail)]
replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
addPart ($(ihamletFile "templates/mail/correctorInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
Nothing -> runDB .
deleteBy $ UniqueSheetCorrectorInvitation sheetCorrectorInvitationEmail sheetCorrectorInvitationSheet

3
src/Jobs/Types.hs
View File

@ -34,6 +34,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
| JobLecturerInvitation { jInviter :: UserId
, jLecturerInvitation :: LecturerInvitation
}
| JobCorrectorInvitation { jInviter :: UserId
, jCorrectorInvitation :: SheetCorrectorInvitation
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }

1
src/Model.hs
View File

@ -41,6 +41,7 @@ deriving instance Eq (Unique Sheet)
deriving instance Binary (Key Term)
instance Hashable LecturerInvitation
instance Hashable SheetCorrectorInvitation
submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingTime

5
src/Model/Types.hs
View File

@ -332,6 +332,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Hashable Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
@ -529,9 +530,11 @@ deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
} ''CorrectorState
instance Universe CorrectorState where universe = universeDef
instance Universe CorrectorState
instance Finite CorrectorState
instance Hashable CorrectorState
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
derivePersistField "CorrectorState"

3
src/Utils/Form.hs
View File

@ -441,6 +441,9 @@ optionsFinite = do
}
return . mkOptionList $ mkOption <$> universeF
rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
rationalField = convertField toRational fromRational doubleField
-----------
-- Forms --

2
src/Utils/Lens.hs
View File

@ -100,6 +100,8 @@ makePrisms ''HandlerContents
makePrisms ''ErrorResponse
makeLenses_ ''SheetCorrectorInvitation
-- makeClassy_ ''Load

4
static/js/utils/checkAll.js
View File

@ -91,12 +91,10 @@
checkboxColumn = columns[checkboxColumnId];
var firstRow = element.querySelector('tr');
var th = Array.from(firstRow.querySelectorAll('th, td'))[checkboxColumnId];
th.innerHTML = 'test';
checkAllCheckbox = document.createElement('input');
checkAllCheckbox.setAttribute('type', 'checkbox');
checkAllCheckbox.setAttribute('id', getCheckboxId());
th.innerHTML = '';
th.insertBefore(checkAllCheckbox, null);
th.insertBefore(checkAllCheckbox, th.firstChild);
// manually set up newly created checkbox
if (UtilRegistry) {

2
static/js/utils/inputs.js
View File

@ -161,7 +161,7 @@
return false;
}
var siblingEl = element.nextElementSibling;
var siblingEl = element.nextSibling;
var parentEl = element.parentElement;
var wrapperEl = document.createElement('div');

11
templates/mail/correctorInvitation.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<body>
<p>
_{MsgSheetCorrInviteExplanation}
<p>
<a href=#{invitationUrl'}>
_{MsgInvitationAcceptDecline}

2
templates/mail/lecturerInvitation.hamlet
View File

@ -8,4 +8,4 @@ $newline never
_{MsgCourseLecInviteExplanation}
<p>
<a href=#{invitationUrl'}>
_{MsgCourseLecturerInvitationAcceptDecline}
_{MsgInvitationAcceptDecline}

3
templates/sheetCorrInvite.hamlet Normal file
View File

@ -0,0 +1,3 @@
<p>
_{MsgSheetCorrInviteExplanation}
^{btnWidget}

6
templates/sheetCorrectors/add.hamlet Normal file
View File

@ -0,0 +1,6 @@
$newline never
<td colspan=5>
#{csrf}
^{fvInput addView}
<td>
^{fvInput submitView}

20
templates/sheetCorrectors/cell.hamlet Normal file
View File

@ -0,0 +1,20 @@
$newline never
$case userIdent
$of Left _
<td>
^{identWidget}
<td>
<div .tooltip>
<div .tooltip__handle>
<div .tooltip__content>
_{MsgEmailInvitationWarning}
$of Right _
<td colspan=2>
^{identWidget}
<td>
#{csrf}
^{fvInput stateView}
<td>
^{fvInput byTutView}
<td>
^{fvInput propView}

18
templates/sheetCorrectors/layout.hamlet Normal file
View File

@ -0,0 +1,18 @@
$newline never
<table .table .table--striped .table--hover>
<thead>
<tr .table__row .table__row--head>
<th .table__th colspan="2">_{MsgCorrector}
<th .table__th>_{MsgCorState}
<th .table__th>_{MsgCorByTut}
<th .table__th>_{MsgCorProportion}
<td>
<tbody>
$forall coord <- review liveCoords lLength
<tr .massinput--cell .table__row>
^{cellWdgts ! coord}
<td>
^{fvInput (delButtons ! coord)}
<tfoot>
<tr .massinput--add>
^{addWdgts ! (0, 0)}

2
templates/widgets/email.hamlet Normal file
View File

@ -0,0 +1,2 @@
<span style="font-family: monospace">
^{toHtml email}