{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Course.Application.List ( getCApplicationsR, postCApplicationsR ) where import Import import Handler.Utils import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import qualified Data.Csv as Csv import qualified Data.Text as Text import qualified Data.Text.Lens as Text import qualified Data.CaseInsensitive as CI 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) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation)) `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures)) `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 , 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 4 1) queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User)) queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) 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 4 2) queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3) queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3) queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) 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 resultUser :: Lens' CourseApplicationsTableData (Entity User) resultUser = _dbrOutput . _2 resultHasFiles :: Lens' CourseApplicationsTableData Bool resultHasFiles = _dbrOutput . _3 resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation) resultAllocation = _dbrOutput . _4 . _Just resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures) resultStudyFeatures = _dbrOutput . _5 . _Just resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms) 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) deriving newtype (Enum, Bounded) makePrisms ''CourseApplicationsTableVeto instance Csv.ToField CourseApplicationsTableVeto where toField (CourseApplicationsTableVeto True) = "veto" toField (CourseApplicationsTableVeto False) = "" instance Csv.FromField CourseApplicationsTableVeto where parseField f = do (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f return . CourseApplicationsTableVeto $ elem t [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] data CourseApplicationsTableCsv = CourseApplicationsTableCsv { csvCAAllocation :: Maybe AllocationShorthand , csvCAApplication :: Maybe CryptoFileNameCourseApplication , csvCAName :: Maybe Text , csvCAMatriculation :: Maybe Text , csvCAField :: Maybe Text , csvCADegree :: Maybe Text , csvCASemester :: Maybe Int , csvCAText :: Maybe Text , csvCAHasFiles :: Maybe Bool , csvCAVeto :: Maybe CourseApplicationsTableVeto , csvCARating :: Maybe ExamGrade , csvCAComment :: Maybe Text } deriving (Generic) makeLenses_ ''CourseApplicationsTableCsv courseApplicationsTableCsvOptions :: Csv.Options courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 } instance Csv.ToNamedRecord CourseApplicationsTableCsv where toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions instance Csv.FromNamedRecord CourseApplicationsTableCsv where parseNamedRecord csv = CourseApplicationsTableCsv <$> csv .:?? "allocation" <*> csv .:?? "application" <*> csv .:?? "name" <*> csv .:?? "matriculation" <*> csv .:?? "field" <*> csv .:?? "degree" <*> csv .:?? "semester" <*> csv .:?? "text" <*> csv .:?? "has-files" <*> csv .:?? "veto" <*> csv .:?? "rating" <*> csv .:?? "comment" instance Csv.DefaultOrdered CourseApplicationsTableCsv where headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions instance CsvColumnsExplained CourseApplicationsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList [ ('csvCAAllocation , MsgCsvColumnApplicationsAllocation ) , ('csvCAApplication , MsgCsvColumnApplicationsApplication ) , ('csvCAName , MsgCsvColumnApplicationsName ) , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation) , ('csvCAField , MsgCsvColumnApplicationsField ) , ('csvCADegree , MsgCsvColumnApplicationsDegree ) , ('csvCASemester , MsgCsvColumnApplicationsSemester ) , ('csvCAText , MsgCsvColumnApplicationsText ) , ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles ) , ('csvCAVeto , MsgCsvColumnApplicationsVeto ) , ('csvCARating , MsgCsvColumnApplicationsRating ) , ('csvCAComment , MsgCsvColumnApplicationsComment ) ] data CourseApplicationsTableCsvActionClass = CourseApplicationsTableCsvSetField | CourseApplicationsTableCsvSetVeto | CourseApplicationsTableCsvSetRating | CourseApplicationsTableCsvSetComment deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id data CourseApplicationsTableCsvAction = CourseApplicationsTableCsvSetFieldData { caCsvActApplication :: CourseApplicationId , caCsvActField :: Maybe StudyFeaturesId } | CourseApplicationsTableCsvSetVetoData { caCsvActApplication :: CourseApplicationId , caCsvActVeto :: Bool } | CourseApplicationsTableCsvSetRatingData { caCsvActApplication :: CourseApplicationId , caCsvActRating :: Maybe ExamGrade } | CourseApplicationsTableCsvSetCommentData { caCsvActApplication :: CourseApplicationId , caCsvActComment :: Maybe Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel , fieldLabelModifier = camelToPathPiece' 3 , sumEncoding = TaggedObject "action" "data" } ''CourseApplicationsTableCsvAction data CourseApplicationsTableCsvException = CourseApplicationsTableCsvExceptionNoMatchingUser | CourseApplicationsTableCsvExceptionNoMatchingAllocation | CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures deriving (Show, Generic, Typeable) 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, mayAccept) <- runDB $ do now <- liftIO getCurrentTime Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh) let allocationLink :: Allocation -> SomeRoute UniWorX allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX) participantLink uid = liftHandler $ do cID <- encrypt uid return . SomeRoute . CourseR tid ssh csh $ CUserR cID applicationLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseApplicationId -> m (SomeRoute UniWorX) applicationLink appId = liftHandler $ do cID <- encrypt appId return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _ dbtSQLQuery = runReaderT $ do courseApplication <- view queryCourseApplication hasFiles <- view queryHasFiles user <- view queryUser allocation <- view queryAllocation 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.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) 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.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.where_ $ E.maybe E.true (E.maybe E.false (E.<=. E.val now)) (allocation E.?. AllocationStaffAllocationFrom) return ( courseApplication , user , hasFiles , allocation , studyFeatures , studyTerms , studyDegree , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId ) dbtProj :: DBRow _ -> DB CourseApplicationsTableData dbtProj = traverse $ return . over _3 E.unValue . over _8 E.unValue dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId) dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat [ 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) , emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText) , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles)) , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto) , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints) , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment) ] dbtSorting = mconcat [ 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 , sortStudyDegree queryStudyDegree , sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester) , sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText) , sortApplicationFiles queryHasFiles , sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto) , sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints) , sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment) ] dbtFilter = mconcat [ fltrAllocation queryAllocation , fltrUserName' $ queryUser . to (E.^. UserDisplayName) , fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer) , fltrStudyTerms queryStudyTerms , fltrStudyDegree queryStudyDegree , fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester) , fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText) , fltrApplicationFiles queryHasFiles , fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto) , fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints) , fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment) ] dbtFilterUI = mconcat [ fltrAllocationUI , fltrUserNameUI' , fltrUserMatriculationUI , fltrStudyTermsUI , fltrStudyDegreeUI , fltrStudyFeaturesSemesterUI , fltrApplicationTextUI , fltrApplicationFilesUI , fltrApplicationVetoUI , fltrApplicationRatingPointsUI , fltrApplicationRatingCommentUI ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv <$> preview (resultAllocation . _entityVal . _allocationShorthand) <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt) <*> preview (resultUser . _entityVal . _userDisplayName) <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just) <*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey))) <*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey))) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just) <*> preview resultHasFiles <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto) <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just) <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do appRes <- lift $ guessUser csv case appRes of Right appId -> return $ E.Value appId Left uid -> do alloc <- lift $ guessAllocation csv [appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2] return $ E.Value appId , dbtCsvComputeActions = \case DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffNew{} -> return () -- no addition DBCsvDiffExisting{..} -> do let appId = dbCsvOld ^. resultCourseApplication . _entityKey newFeatures <- lift $ lookupStudyFeatures dbCsvNew when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto whenIsJust mVeto $ \veto -> when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $ yield $ CourseApplicationsTableCsvSetVetoData appId veto when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $ yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating) when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $ yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment) , dbtCsvClassifyAction = \case CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment , dbtCsvCoarsenActionClass = const DBCsvActionExisting , dbtCsvExecuteActions = do C.mapM_ $ \case CourseApplicationsTableCsvSetFieldData{..} -> do CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField , CourseApplicationTime =. now ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetVetoData{..} -> do CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto , CourseApplicationRatingTime =. Just now ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetRatingData{..} -> do CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating , CourseApplicationRatingTime =. Just now ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetCommentData{..} -> do CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment , CourseApplicationRatingTime =. Just now ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication return $ CourseR tid ssh csh CApplicationsR , dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case CourseApplicationsTableCsvSetFieldData{..} -> [whamlet| $newline never ^{existingApplicantName' caCsvActApplication} $maybe features <- caCsvActField , ^{studyFeaturesWidget features} $nothing , _{MsgCourseStudyFeatureNone} |] CourseApplicationsTableCsvSetVetoData{..} -> [whamlet| $newline never ^{existingApplicantName' caCsvActApplication} $if caCsvActVeto , _{MsgCourseApplicationVeto} $else , _{MsgCourseApplicationNoVeto} |] CourseApplicationsTableCsvSetRatingData{..} -> [whamlet| $newline never ^{existingApplicantName' caCsvActApplication} $maybe newResult <- caCsvActRating , _{newResult} $nothing , _{MsgCourseApplicationNoRatingPoints} |] CourseApplicationsTableCsvSetCommentData{..} -> [whamlet| $newline never ^{existingApplicantName' caCsvActApplication} $if is _Nothing caCsvActComment , _{MsgCourseApplicationNoRatingComment} |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text } where guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId) guessUser csv = do mApp <- runMaybeT $ do appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just CourseApplication{..} <- MaybeT $ get appId guard $ courseApplicationCourse == cid return appId maybe (Left <$> guessUser' csv) (return . Right) mApp where guessUser' :: CourseApplicationsTableCsv -> DB UserId guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do users <- E.select . E.from $ \user -> do E.where_ . E.and $ catMaybes [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation , (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName ] return $ user E.^. UserId case users of [E.Value uid] -> return uid _other -> throwM CourseApplicationsTableCsvExceptionNoMatchingUser guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId) guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid case mAlloc of Just (Entity allocId Allocation{..}) | allocationShorthand == ash -> return allocId _other -> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname where Entity _ User{..} = existing ^. singular (ix appId . resultUser) lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId) lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do appRes <- guessUser csv (uid, oldFeatures) <- case appRes of Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] [] Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField) , E.asc (studyFeatures E.^. StudyFeaturesDegree) , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree E.where_ . E.and $ catMaybes [ do field <- csvCAField return . E.or $ catMaybes [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field ] , do degree <- csvCADegree return . E.or $ catMaybes [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree ] , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester ] E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid let isActiveOrPrevious = E.or $ (studyFeatures E.^. StudyFeaturesValid) : [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId | Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures ] E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)] return $ studyFeatures E.^. StudyFeaturesId case studyFeatures of [E.Value fid] -> return $ Just fid _other | is _Nothing csvCAField , is _Nothing csvCADegree , is _Nothing csvCASemester -> return Nothing _other | [Entity _ CourseApplication{..}] <- oldFeatures , Just sfid <- courseApplicationField , E.Value sfid `elem` studyFeatures -> return $ Just sfid _other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures dbtIdent = courseApplicationsIdent psValidator :: PSValidator _ _ psValidator = def & defaultSorting [SortAscBy "user-name"] participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] let remainingCapacity = subtract participants <$> courseCapacity allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid let numApps addWhere = E.subSelectCount . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation) addWhere courseApplication numApps' = numApps . const $ return () numFirstChoice = numApps $ \courseApplication -> E.where_ . E.not_ . E.exists . E.from $ \courseApplication' -> do E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. courseApplication' E.^. CourseApplicationAllocation E.&&. courseApplication E.^. CourseApplicationUser E.==. courseApplication' E.^. CourseApplicationUser E.where_ . E.not_ $ E.isNothing (courseApplication E.^. CourseApplicationAllocationPriority) E.||. E.isNothing (courseApplication' E.^. CourseApplicationAllocationPriority) E.where_ $ courseApplication' E.^. CourseApplicationAllocationPriority E.>. courseApplication E.^. CourseApplicationAllocationPriority return (allocation, numApps', numFirstChoice) let allocationsBounds = [ (allocation, numApps', numFirstChoice', capped) | (Entity _ allocation, E.Value numApps, E.Value numFirstChoice) <- allocationsBounds' , let numApps' = max 0 $ maybe id min remainingCapacity numApps numFirstChoice' = max 0 $ maybe id min remainingCapacity numFirstChoice capped = numApps' /= numApps || numFirstChoice' /= numFirstChoice ] 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, CourseParticipantState ==. CourseParticipantActive ] 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 E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive 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 let studyFeaturesWarning = $(i18nWidgetFile "applications-list-info") siteLayoutMsg title $ do setTitleI title $(widgetFile "course/applications-list")