From 5e393c53c6a702a88e053e585c1d38cb5fea15bf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 23 Aug 2019 10:15:59 +0200 Subject: [PATCH] feat(allocations): serve archive of all application files by course --- messages/uniworx/de.msg | 4 + models/allocations | 6 +- models/users | 8 +- routes | 1 + src/Foundation.hs | 22 +++ src/Handler/Course/Application.hs | 230 +----------------------- src/Handler/Course/Application/Files.hs | 108 +++++++++++ src/Handler/Course/Application/List.hs | 201 +++++++++++++++++++++ src/Model.hs | 8 - src/Utils.hs | 6 + src/Utils/DB.hs | 12 ++ src/Utils/Lens.hs | 2 + 12 files changed, 366 insertions(+), 242 deletions(-) create mode 100644 src/Handler/Course/Application/Files.hs create mode 100644 src/Handler/Course/Application/List.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 256f2a000..e61f792a6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -206,6 +206,9 @@ CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in U CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden CourseApplicationArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand appId@CryptoFileNameCourseApplication displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase (toPathPiece appId)}-#{foldCase displayName} +CourseAllApplicationsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen +CourseApplicationsAllocatedDirectory: zentral +CourseApplicationsNotAllocatedDirectory: direkt CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden @@ -1027,6 +1030,7 @@ MenuExamUsers: Teilnehmer MenuExamAddMembers: Prüfungsteilnehmer hinzufügen MenuLecturerInvite: Dozenten hinzufügen MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung +MenuCourseApplicationsFiles: Dateien aller Bewerbungen AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate diff --git a/models/allocations b/models/allocations index 0fac2cfee..9ddbd59bd 100644 --- a/models/allocations +++ b/models/allocations @@ -1,8 +1,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students - name AllocationName - shorthand AllocationShorthand -- practical shorthand term TermId school SchoolId -- school that manages this central allocation, not necessarily school of courses + shorthand AllocationShorthand -- practical shorthand + name AllocationName description Html Maybe -- description for prospective students staffDescription Html Maybe -- description seen by prospective lecturers only staffRegisterFrom UTCTime Maybe -- lectureres may register courses @@ -23,7 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis -- overrideVisible not needed, since courses are always visible TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester TermSchoolAllocationName term school name -- name must be unique within school and semester - deriving Show + deriving Show Eq Ord Generic AllocationCourse allocation AllocationId diff --git a/models/users b/models/users index 155970f60..f66651dd5 100644 --- a/models/users +++ b/models/users @@ -8,14 +8,14 @@ -- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname -- User json -- Each Uni2work user has a corresponding row in this table; created upon first login. + surname UserSurname -- Display user names always through 'nameWidget displayName surname' + displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) + email (CI Text) -- Case-insensitive eMail address ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) - email (CI Text) -- Case-insensitive eMail address - displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) - surname UserSurname -- Display user names always through 'nameWidget displayName surname' firstName Text -- For export in tables, pre-split firstName from displayName title Text Maybe -- For upcoming name customisation maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined @@ -29,7 +29,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table - deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory + deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user user UserId school SchoolId diff --git a/routes b/routes index 88099df1a..d801d285c 100644 --- a/routes +++ b/routes @@ -163,6 +163,7 @@ /users/invite EInviteR GET POST /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result /apps CApplicationsR GET POST + !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: /files CAFilesR GET !self !lecturerANDtime diff --git a/src/Foundation.hs b/src/Foundation.hs index 9748f0b47..2d79722e1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2708,6 +2708,28 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CApplicationsR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCourseApplicationsFiles + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAppsFilesR + , menuItemModal = False + , menuItemAccessCallback' + = let appAccess (E.Value appId) = do + cID <- encrypt appId + hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR + appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.where_ . E.exists . E.from $ \courseApplicationFile -> + E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId + return $ courseApplication E.^. CourseApplicationId + in runDB . runConduit $ appSource .| anyMC appAccess + } + ] pageActions (CorrectionsR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs index 998ff9670..bcb5146a1 100644 --- a/src/Handler/Course/Application.hs +++ b/src/Handler/Course/Application.hs @@ -1,230 +1,6 @@ module Handler.Course.Application - ( getCAFilesR - , getCApplicationsR, postCApplicationsR + ( module Handler.Course.Application ) 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 +import Handler.Course.Application.List as Handler.Course.Application +import Handler.Course.Application.Files as Handler.Course.Application diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs new file mode 100644 index 000000000..fc42b8e39 --- /dev/null +++ b/src/Handler/Course/Application/Files.hs @@ -0,0 +1,108 @@ +module Handler.Course.Application.Files + ( getCAFilesR + , getCAppsFilesR + ) where + +import Import +import Handler.Utils + +import System.FilePath (addExtension, ()) + +import qualified Data.Conduit.List as C + +import qualified Database.Esqueleto as E + +import qualified Data.CaseInsensitive as CI + + +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 + + +getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent +getCAppsFilesR tid ssh csh = do + runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh + MsgRenderer mr <- getMsgRenderer + + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh + + let + fsSource :: Source DB File + fsSource = do + apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do + E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation + E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (allocation, user, courseApplication) + apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do + cID <- cachedByBinary appId $ encrypt appId + hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR + let + applicationAllocs = setOf (folded . _1) apps' + + allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand + + allEqualOn :: Eq x => Getter _ x -> Bool + allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l) + + mkAllocationDir mbAlloc + | not $ allEqualOn _1 + , Just Allocation{..} <- mbAlloc + = () $ unpack [st|#{CI.foldCase (termToText (unTermKey allocationTerm))}-#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|] + | not $ allEqualOn _2 + , Just Allocation{..} <- mbAlloc + = () $ unpack [st|#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|] + | not $ allEqualOn _3 + , Just Allocation{..} <- mbAlloc + = () . unpack $ CI.foldedCase allocationShorthand + | Just Allocation{} <- mbAlloc + , not $ all (is _Just) applicationAllocs + = () . unpack $ mr MsgCourseApplicationsAllocatedDirectory + | Nothing <- mbAlloc + , any (is _Just) applicationAllocs + = () . unpack $ mr MsgCourseApplicationsNotAllocatedDirectory + | otherwise + = id + + forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do + cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication + let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . () (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|]) + dirFiles = C.map $ over _fileTitle mkAppDir . entityVal + fileEntitySource = 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 + + yield $ File + { fileModified = courseApplicationTime + , fileTitle = mkAppDir "" + , fileContent = Nothing + } + + fileEntitySource .| dirFiles + + + serveSomeFiles archiveName fsSource diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs new file mode 100644 index 000000000..966e29a44 --- /dev/null +++ b/src/Handler/Course/Application/List.hs @@ -0,0 +1,201 @@ +module Handler.Course.Application.List + ( getCApplicationsR, postCApplicationsR + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Table.Columns + +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils.TH + + +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 diff --git a/src/Model.hs b/src/Model.hs index b63b39a19..d798d98bf 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -40,14 +40,6 @@ deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial deriving instance Eq (Unique Exam) -instance Ord User where - compare User{userSurname=surnameA, userDisplayName=displayNameA, userEmail=emailA} - User{userSurname=surnameB, userDisplayName=displayNameB, userEmail=emailB} - = compare surnameA surnameB - <> compare displayNameA displayNameB - <> compare emailA emailB -- userEmail is unique, so this suffices - - submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Utils.hs b/src/Utils.hs index 91a53cdb9..7bea6fcd0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -42,6 +42,8 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.List as List +import qualified Data.Conduit.List as C + import Control.Lens import Control.Lens as Utils (none) @@ -676,6 +678,10 @@ peekN n = do peeked <- catMaybes <$> replicateM (fromIntegral n) await mapM_ leftover peeked return peeked + +anyMC, allMC :: Monad m => (a -> m Bool) -> Consumer a m Bool +anyMC f = C.mapM f .| orC +allMC f = C.mapM f .| andC ----------------- -- Alternative -- diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 326cef129..412e2527f 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -40,10 +40,18 @@ getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity => Unique record -> ReaderT backend m (Key record) getKeyBy404 u = getKeyBy u >>= maybe notFound return +getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m) + => Key val -> ReaderT backend m (Entity val) +getEntity404 k = Entity <$> pure k <*> get404 k + existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) => Unique record -> ReaderT backend m Bool existsBy = fmap (is _Just) . getKeyBy +existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m) + => Unique record -> ReaderT backend m () +existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy + existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m) => Key record -> ReaderT backend m Bool existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record @@ -52,6 +60,10 @@ exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity reco => [Filter record] -> ReaderT backend m Bool exists = fmap (not . null) . flip selectKeysList [LimitTo 1] +exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m) + => [Filter record] -> ReaderT backend m () +exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1] + updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend ) => Unique record -> [Update record] -> ReaderT backend m () updateBy uniq updates = do diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8f1cc1357..d72fdac3e 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -165,6 +165,8 @@ makeLenses_ ''CourseApplication makeLenses_ ''Allocation +makeLenses_ ''File + -- makeClassy_ ''Load