231 lines
11 KiB
Haskell
231 lines
11 KiB
Haskell
module Handler.Course.Application
|
|
( getCAFilesR
|
|
, getCApplicationsR, postCApplicationsR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Columns
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import System.FilePath (addExtension)
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
|
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
|
|
getCAFilesR tid ssh csh cID = do
|
|
appId <- decrypt cID
|
|
User{..} <- runDB $ do
|
|
CourseApplication{..} <- get404 appId
|
|
Course{..} <- get404 courseApplicationCourse
|
|
let matches = and
|
|
[ tid == courseTerm
|
|
, ssh == courseSchool
|
|
, csh == courseShorthand
|
|
]
|
|
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
|
get404 courseApplicationUser
|
|
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
|
|
let
|
|
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
|
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
|
return file
|
|
|
|
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
|
|
|
|
|
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))
|
|
)
|
|
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
|
, Entity User
|
|
, E.Value Bool -- hasFiles
|
|
, Maybe (Entity Allocation)
|
|
, Maybe (Entity StudyFeatures)
|
|
, Maybe (Entity StudyTerms)
|
|
, Maybe (Entity StudyDegree)
|
|
)
|
|
|
|
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)
|
|
|
|
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
|
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
|
|
|
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
|
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
|
|
|
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
|
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(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 . _Value
|
|
|
|
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
|
|
|
|
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCApplicationsR = postCApplicationsR
|
|
postCApplicationsR tid ssh csh = do
|
|
table <- runDB $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
|
|
let
|
|
allocationLink :: Allocation -> SomeRoute UniWorX
|
|
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
|
|
|
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
|
participantLink uid = do
|
|
cID <- encrypt uid
|
|
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
|
|
|
|
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
|
|
|
|
lift $ do
|
|
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
|
|
|
|
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
|
|
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
|
dbtProj = runReaderT $ do
|
|
appId <- view $ resultCourseApplication . _entityKey
|
|
cID <- encrypt appId
|
|
|
|
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR -- TODO: replace with CAShowR
|
|
|
|
view id
|
|
|
|
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
|
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat
|
|
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
|
, 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 ($(multifocusL 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
|
|
[ 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 = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
dbtIdent = courseApplicationsIdent
|
|
|
|
psValidator :: PSValidator _ _
|
|
psValidator = def
|
|
|
|
dbTableWidget' psValidator DBTable{..}
|
|
|
|
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
|
|
|
siteLayoutMsg title $ do
|
|
setTitleI title
|
|
table
|