565 lines
28 KiB
Haskell
565 lines
28 KiB
Haskell
{-# 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 CourseParticipant))
|
|
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
|
, Entity User
|
|
, Bool -- hasFiles
|
|
, Maybe (Entity Allocation)
|
|
, Bool -- isParticipant
|
|
)
|
|
|
|
courseApplicationsIdent :: Text
|
|
courseApplicationsIdent = "applications"
|
|
|
|
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
|
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
|
|
|
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
|
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
|
|
|
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
|
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 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)
|
|
|
|
queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
|
|
queryCourseParticipant = to $(sqlLOJproj 3 3)
|
|
|
|
queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
|
queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 3 3)
|
|
|
|
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
|
|
|
|
resultIsParticipant :: Lens' CourseApplicationsTableData Bool
|
|
resultIsParticipant = _dbrOutput . _5
|
|
|
|
|
|
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
|
|
, csvCAEmail :: Maybe UserEmail
|
|
, csvCAMatriculation :: Maybe Text
|
|
, 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 .:?? "email"
|
|
<*> csv .:?? "matriculation"
|
|
<*> 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 )
|
|
, ('csvCAEmail , MsgCsvColumnApplicationsEmail )
|
|
, ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
|
|
, ('csvCAText , MsgCsvColumnApplicationsText )
|
|
, ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles )
|
|
, ('csvCAVeto , MsgCsvColumnApplicationsVeto )
|
|
, ('csvCARating , MsgCsvColumnApplicationsRating )
|
|
, ('csvCAComment , MsgCsvColumnApplicationsComment )
|
|
]
|
|
|
|
data CourseApplicationsTableCsvActionClass
|
|
= CourseApplicationsTableCsvSetVeto
|
|
| CourseApplicationsTableCsvSetRating
|
|
| CourseApplicationsTableCsvSetComment
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
|
|
|
|
data CourseApplicationsTableCsvAction
|
|
= 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
|
|
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 $ 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
|
|
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
|
|
)
|
|
|
|
dbtProj :: DBRow _ -> DB CourseApplicationsTableData
|
|
dbtProj = traverse $ return . over _3 E.unValue . over _5 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)
|
|
, lmap (view $ resultUser . _entityVal) colUserEmail
|
|
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
|
, 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))
|
|
, uncurry singletonMap . sortUserEmail $ view queryUser
|
|
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
|
, 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)
|
|
, uncurry singletonMap . fltrUserEmail $ view queryUser
|
|
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
|
, 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
|
|
, fltrUserEmailUI
|
|
, 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 . _userEmail)
|
|
<*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
|
|
<*> 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
|
|
|
|
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
|
|
CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto
|
|
CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating
|
|
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
|
|
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
|
|
, dbtCsvExecuteActions = do
|
|
C.mapM_ $ \case
|
|
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
|
|
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.^. UserEmail E.==.) . E.val <$> csvCAEmail
|
|
, (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)
|
|
|
|
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")
|