feat(course-applications): automatic acceptance of direct applicants
This commit is contained in:
Gregor Kleen
parent
16abcd2265
commit
620950df83
@ -173,6 +173,7 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
|
||||
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
|
||||
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
|
||||
CourseApplication: Bewerbung
|
||||
CourseApplicationIsParticipant: Kursteilnehmer
|
||||
|
||||
CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
|
||||
CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden
|
||||
@ -1529,7 +1530,7 @@ CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studien
|
||||
CsvColumnApplicationsText: Text-Bewerbung
|
||||
CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)?
|
||||
CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer
|
||||
CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0"
|
||||
CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" (Leer wird behandelt wie eine Note zwischen 2.3 und 2.7)
|
||||
CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
|
||||
|
||||
Action: Aktion
|
||||
@ -1785,4 +1786,15 @@ ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsämter, die
|
||||
ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht.
|
||||
ExamDidClose: Klausur erfolgreich abgeschlossen
|
||||
|
||||
ExamClosedSince time@Text: Klausur abgeschlossen seit #{time}
|
||||
ExamClosedSince time@Text: Klausur abgeschlossen seit #{time}
|
||||
|
||||
BtnAcceptApplications: Bewerbungen akzeptieren
|
||||
BtnAcceptApplicationsTip: Mit dem untigen Knopf können Sie den Kurs (höchstens bis zur angegeben Maximalkapazität, falls eingestellt) mit Bewerbern auffüllen. Die Bewertungen der Bewerbungen werden dabei berücksichtigt (Unbewertet wird behandelt wie eine Note zwischen 2.3 und 2.7). Bewerber mit Veto oder 5.0 werden nicht angemeldet.
|
||||
AcceptApplicationsMode: Bewerbungen akzeptieren
|
||||
AcceptApplicationsModeTip: Sollen akzeptierte Bewerber direkt als Teilnehmer im Kurs eingetragen werden oder sollen Einladungen per E-Mail verschickt werden?
|
||||
AcceptApplicationsDirect: Direkt anmelden
|
||||
AcceptApplicationsInvite: Einladungen verschicken
|
||||
AcceptApplicationsSecondary: Gleichstände auflösen
|
||||
AcceptApplicationsSecondaryTip: Wenn es im Laufe des Verfahrens mehrere Bewerber mit der selben Bewertung für den selben Platz gibt, wie soll der Gleichstand aufgelöst werden?
|
||||
AcceptApplicationsSecondaryRandom: Zufällig
|
||||
AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung
|
||||
@ -25,6 +25,10 @@ import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Handler.Course.ParticipantInvite
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
@ -34,41 +38,49 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, E.Value Bool -- hasFiles
|
||||
, Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
, Bool -- isParticipant
|
||||
)
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
|
||||
|
||||
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
|
||||
|
||||
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
|
||||
where
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||
queryAllocation = to $(sqlLOJproj 3 2)
|
||||
queryAllocation = to $(sqlLOJproj 4 2)
|
||||
|
||||
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
|
||||
queryCourseParticipant = to $(sqlLOJproj 4 4)
|
||||
|
||||
queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4)
|
||||
|
||||
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||
resultCourseApplication = _dbrOutput . _1
|
||||
@ -77,7 +89,7 @@ resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||
resultHasFiles = _dbrOutput . _3 . _Value
|
||||
resultHasFiles = _dbrOutput . _3
|
||||
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
@ -91,6 +103,9 @@ resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
resultIsParticipant :: Lens' CourseApplicationsTableData Bool
|
||||
resultIsParticipant = _dbrOutput . _8
|
||||
|
||||
|
||||
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
@ -205,12 +220,44 @@ data CourseApplicationsTableCsvException
|
||||
instance Exception CourseApplicationsTableCsvException
|
||||
|
||||
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
|
||||
|
||||
|
||||
data ButtonAcceptApplications = BtnAcceptApplications
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonAcceptApplications
|
||||
instance Finite ButtonAcceptApplications
|
||||
|
||||
nullaryPathPiece ''ButtonAcceptApplications $ camelToPathPiece' 1
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonAcceptApplications id
|
||||
instance Button UniWorX ButtonAcceptApplications where
|
||||
btnClasses BtnAcceptApplications = [BCIsButton]
|
||||
|
||||
data AcceptApplicationsMode = AcceptApplicationsInvite
|
||||
| AcceptApplicationsDirect
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe AcceptApplicationsMode
|
||||
instance Finite AcceptApplicationsMode
|
||||
|
||||
nullaryPathPiece ''AcceptApplicationsMode $ camelToPathPiece' 2
|
||||
|
||||
embedRenderMessage ''UniWorX ''AcceptApplicationsMode id
|
||||
|
||||
data AcceptApplicationsSecondary = AcceptApplicationsSecondaryRandom
|
||||
| AcceptApplicationsSecondaryTime
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe AcceptApplicationsSecondary
|
||||
instance Finite AcceptApplicationsSecondary
|
||||
|
||||
nullaryPathPiece ''AcceptApplicationsSecondary $ camelToPathPiece' 3
|
||||
|
||||
embedRenderMessage ''UniWorX ''AcceptApplicationsSecondary id
|
||||
|
||||
|
||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCApplicationsR = postCApplicationsR
|
||||
postCApplicationsR tid ssh csh = do
|
||||
(table, allocationsBounds) <- runDB $ do
|
||||
(table, allocationsBounds, mayAccept) <- runDB $ do
|
||||
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
|
||||
@ -237,31 +284,43 @@ postCApplicationsR tid ssh csh = do
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
courseParticipant <- view queryCourseParticipant
|
||||
|
||||
lift $ do
|
||||
E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
|
||||
E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
|
||||
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
||||
return ( courseApplication
|
||||
, user
|
||||
, hasFiles
|
||||
, allocation
|
||||
, studyFeatures
|
||||
, studyTerms
|
||||
, studyDegree
|
||||
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
|
||||
)
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
||||
dbtProj = runReaderT $ do
|
||||
appId <- view $ resultCourseApplication . _entityKey
|
||||
appId <- view $ _dbrOutput . _1 . _entityKey
|
||||
cID <- encrypt appId
|
||||
|
||||
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
|
||||
|
||||
view id
|
||||
asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue
|
||||
|
||||
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||
[ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant
|
||||
, emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||
, anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey)
|
||||
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
@ -276,7 +335,8 @@ postCApplicationsR tid ssh csh = do
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||
[ singletonMap "participant" . SortColumn $ view queryIsParticipant
|
||||
, sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
@ -566,12 +626,67 @@ postCApplicationsR tid ssh csh = do
|
||||
|| numFirstChoice' /= numFirstChoice
|
||||
]
|
||||
|
||||
(, allocationsBounds) <$> dbTableWidget' psValidator DBTable{..}
|
||||
mayAccept <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
|
||||
|
||||
(, allocationsBounds, mayAccept) <$> dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||
registrationOpen = maybe True (now <)
|
||||
|
||||
|
||||
((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
|
||||
(,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
|
||||
<*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)
|
||||
|
||||
let acceptWgt = wrapForm' BtnAcceptApplications acceptWgt' def
|
||||
{ formSubmit = FormSubmit
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CApplicationsR
|
||||
, formEncoding = acceptEnc
|
||||
}
|
||||
|
||||
when mayAccept $
|
||||
formResult acceptRes $ \(invMode, appsSecOrder) -> do
|
||||
runDBJobs $ do
|
||||
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
participants <- count [ CourseParticipantCourse ==. cid ]
|
||||
let openCapacity = subtract participants <$> courseCapacity
|
||||
|
||||
applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do
|
||||
E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser
|
||||
|
||||
E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid
|
||||
E.&&. E.isNothing (application E.^. CourseApplicationAllocation)
|
||||
E.&&. E.not_ (application E.^. CourseApplicationRatingVeto)
|
||||
E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints )
|
||||
|
||||
E.where_ . E.not_ . E.exists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
|
||||
return (user, application)
|
||||
|
||||
let
|
||||
ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter)
|
||||
cmp = case appsSecOrder of
|
||||
AcceptApplicationsSecondaryTime
|
||||
-> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime)
|
||||
AcceptApplicationsSecondaryRandom
|
||||
-> comparing $ view ratingL
|
||||
sortedApplications <- unstableSortBy cmp applications
|
||||
|
||||
let applicants = sortedApplications
|
||||
& nubOn (view $ _1 . _entityKey)
|
||||
& maybe id take openCapacity
|
||||
& setOf (case invMode of
|
||||
AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
|
||||
AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
|
||||
)
|
||||
|
||||
mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
$(widgetFile "course/applications-list")
|
||||
|
||||
@ -4,6 +4,9 @@ module Handler.Course.ParticipantInvite
|
||||
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
, getCInviteR, postCInviteR
|
||||
, getCAddUserR, postCAddUserR
|
||||
, AddParticipantsResult(..)
|
||||
, addParticipantsResultMessages
|
||||
, registerUsers, registerUser
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -96,16 +99,16 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
data AddParticipantsResult = AddParticipantsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurSuccess :: [UserEmail]
|
||||
, aurSuccess :: Set UserId
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Semigroup AddRecipientsResult where
|
||||
instance Semigroup AddParticipantsResult where
|
||||
(<>) = mappenddefault
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
instance Monoid AddParticipantsResult where
|
||||
mempty = memptydefault
|
||||
mappend = (<>)
|
||||
|
||||
@ -118,7 +121,9 @@ postCAddUserR tid ssh csh = do
|
||||
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
||||
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
|
||||
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid
|
||||
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
|
||||
hoist runDBJobs . registerUsers cid
|
||||
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
@ -128,57 +133,74 @@ postCAddUserR tid ssh csh = do
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
}
|
||||
where
|
||||
processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
|
||||
processUsers cid users = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
AddRecipientsResult{..} <- lift . runDBJobs $ do
|
||||
-- send Invitation eMails to unkown users
|
||||
sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
||||
-- register known users
|
||||
execWriterT $ mapM (registerUser cid) uids
|
||||
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
||||
registerUsers cid users = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
-- send Invitation eMails to unkown users
|
||||
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
||||
-- register known users
|
||||
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids
|
||||
|
||||
unless (null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid uid = exceptT tell tell $ do
|
||||
User{..} <- lift . lift $ getJust uid
|
||||
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> AddParticipantsResult
|
||||
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
||||
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
||||
(aurAlreadyRegistered', aurNoUniquePrimaryField') <-
|
||||
(,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
|
||||
<*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
|
||||
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
unless (null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features = Just f
|
||||
| otherwise = Nothing
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
registerUser :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
|
||||
=> CourseId
|
||||
-> UserId
|
||||
-> WriterT AddParticipantsResult (ReaderT (YesodPersistBackend UniWorX) m) ()
|
||||
registerUser cid uid = exceptT tell tell $ do
|
||||
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
|
||||
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features
|
||||
= Just f
|
||||
| [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications
|
||||
, f' `elem` features
|
||||
= Just f'
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
|
||||
Just _ -> mempty { aurSuccess = Set.singleton uid }
|
||||
|
||||
|
||||
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
|
||||
@ -20,7 +20,6 @@ import Control.Monad.State.Class as State
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
|
||||
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
import qualified System.Random.Shuffle as Rand (shuffleM)
|
||||
|
||||
import Data.Maybe ()
|
||||
|
||||
@ -248,9 +247,6 @@ planSubmissions sid restriction = do
|
||||
maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
|
||||
maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
|
||||
|
||||
unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
|
||||
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) ()
|
||||
submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
|
||||
|
||||
@ -88,6 +88,10 @@ import Control.Monad.Trans.State as Import
|
||||
( state, State, runState, mapState, withState
|
||||
, StateT(..), mapStateT, withStateT
|
||||
)
|
||||
import Control.Monad.Trans.Writer.Lazy as Import
|
||||
( writer, Writer, runWriter, mapWriter, execWriter
|
||||
, WriterT(..), mapWriterT, execWriterT
|
||||
)
|
||||
import Control.Monad.Base as Import
|
||||
import Control.Monad.Catch as Import hiding (Handler(..))
|
||||
import Control.Monad.Trans.Control as Import hiding (embed)
|
||||
|
||||
@ -13,6 +13,7 @@ module Model.Types.Exam
|
||||
, ExamOccurrenceRule(..)
|
||||
, ExamGrade(..)
|
||||
, numberGrade
|
||||
, ExamGradeDefCenter(..)
|
||||
, ExamGradingRule(..)
|
||||
, ExamPassed(..)
|
||||
, passingGrade
|
||||
@ -218,6 +219,15 @@ instance PersistFieldSql ExamGrade where
|
||||
sqlType _ = SqlNumeric 2 1
|
||||
|
||||
|
||||
newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade }
|
||||
deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Ord ExamGradeDefCenter where
|
||||
ExamGradeDefCenter Nothing <= ExamGradeDefCenter (Just g) = Grade23 <= g
|
||||
ExamGradeDefCenter (Just g) <= ExamGradeDefCenter Nothing = g <= Grade27
|
||||
ExamGradeDefCenter g <= ExamGradeDefCenter g' = g <= g'
|
||||
|
||||
|
||||
data ExamGradingRule
|
||||
= ExamGradingKey
|
||||
{ examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@
|
||||
|
||||
16
src/Utils.hs
16
src/Utils.hs
@ -85,6 +85,9 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded
|
||||
|
||||
import Data.Constraint (Dict(..))
|
||||
|
||||
import Control.Monad.Random.Class (MonadRandom)
|
||||
import qualified System.Random.Shuffle as Rand (shuffleM)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use asum" :: String) #-}
|
||||
|
||||
|
||||
@ -953,3 +956,16 @@ clampMin, clampMax :: Ord a
|
||||
-> a -- ^ Clamped Value
|
||||
clampMin = max
|
||||
clampMax = min
|
||||
|
||||
------------
|
||||
-- Random --
|
||||
------------
|
||||
|
||||
unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
|
||||
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
|
||||
|
||||
unstableSortOn :: (MonadRandom m, Ord b) => (a -> b) -> [a] -> m [a]
|
||||
unstableSortOn = unstableSortBy . comparing
|
||||
|
||||
unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a]
|
||||
unstableSort = unstableSortBy compare
|
||||
|
||||
@ -26,6 +26,7 @@ import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT)
|
||||
import Control.Monad.Base (MonadBase)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Control.Monad.Catch (MonadMask, MonadCatch)
|
||||
import Control.Monad.Random.Class (MonadRandom)
|
||||
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site)
|
||||
@ -40,6 +41,9 @@ deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site)
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadRandom (HandlerFor site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadRandom (WidgetFor site)
|
||||
|
||||
|
||||
-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
|
||||
newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a }
|
||||
|
||||
@ -1,22 +1,28 @@
|
||||
$newline never
|
||||
$if not (null allocationsBounds)
|
||||
<h2>_{MsgCourseAllocationsBounds (length allocationsBounds)}
|
||||
<dl .deflist>
|
||||
$forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds
|
||||
<dt .deflist__dt>
|
||||
#{allocationName}
|
||||
<dd .deflist__dd>
|
||||
<p>
|
||||
$if numApps == numFirstChoice
|
||||
_{MsgCourseAllocationsBoundCoincide numFirstChoice}
|
||||
$else
|
||||
_{MsgCourseAllocationsBound numApps numFirstChoice}
|
||||
$if capped
|
||||
<p .bound_explanation>
|
||||
_{MsgCourseAllocationsBoundCapped}
|
||||
$if registrationOpen allocationRegisterTo
|
||||
<p .bound_explanation>
|
||||
_{MsgCourseAllocationsBoundWarningOpen}
|
||||
<section>
|
||||
<h2>_{MsgCourseAllocationsBounds (length allocationsBounds)}
|
||||
<dl .deflist>
|
||||
$forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds
|
||||
<dt .deflist__dt>
|
||||
#{allocationName}
|
||||
<dd .deflist__dd>
|
||||
<p>
|
||||
$if numApps == numFirstChoice
|
||||
_{MsgCourseAllocationsBoundCoincide numFirstChoice}
|
||||
$else
|
||||
_{MsgCourseAllocationsBound numApps numFirstChoice}
|
||||
$if capped
|
||||
<p .bound_explanation>
|
||||
_{MsgCourseAllocationsBoundCapped}
|
||||
$if registrationOpen allocationRegisterTo
|
||||
<p .bound_explanation>
|
||||
_{MsgCourseAllocationsBoundWarningOpen}
|
||||
$if mayAccept
|
||||
<section>
|
||||
<p>_{MsgBtnAcceptApplicationsTip}
|
||||
^{acceptWgt}
|
||||
|
||||
<h2>_{MsgMenuCourseApplications}
|
||||
^{table}
|
||||
<section>
|
||||
<h2>_{MsgMenuCourseApplications}
|
||||
^{table}
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}
|
||||
<ul>
|
||||
$forall email <- aurAlreadyRegistered
|
||||
$forall email <- aurAlreadyRegistered'
|
||||
<li style="font-family: monospace">#{email}
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}
|
||||
<ul>
|
||||
$forall email <- aurNoUniquePrimaryField
|
||||
$forall email <- aurNoUniquePrimaryField'
|
||||
<li style="font-family: monospace">#{email}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user