From 5e393c53c6a702a88e053e585c1d38cb5fea15bf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 23 Aug 2019 10:15:59 +0200 Subject: [PATCH 01/13] 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 From e816a30b353f6451f48c97cc9a315f9b3aebb3a5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 26 Aug 2019 10:02:18 +0200 Subject: [PATCH 02/13] feat: allow editing of course applications outside of allocation --- frontend/src/utils/inputs/inputs.scss | 24 +++++-- messages/uniworx/de.msg | 2 + routes | 4 +- src/Foundation.hs | 68 +++++++++--------- src/Handler/Allocation/Application.hs | 98 +++++++++----------------- src/Handler/Allocation/Show.hs | 8 ++- src/Handler/Course/Application.hs | 1 + src/Handler/Course/Application/Edit.hs | 55 +++++++++++++++ src/Handler/Course/Application/List.hs | 2 +- templates/widgets/aform/aform.hamlet | 3 + 10 files changed, 155 insertions(+), 110 deletions(-) create mode 100644 src/Handler/Course/Application/Edit.hs diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index ae81b82d4..c4cb63373 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -1,6 +1,15 @@ /* GENERAL STYLES FOR FORMS */ /* FORM GROUPS */ +.form-section-title { + color: var(--color-fontsec); + margin: 0; + + + .form-group { + margin-top: 11px; + } +} + .form-group { position: relative; display: flex; @@ -19,15 +28,22 @@ } } -.form-section-title { - color: var(--color-fontsec); -} - .form-section-legend { color: var(--color-fontsec); margin: 7px 0; } +.form-section-title__hint { + margin-top: 7px; + color: var(--color-fontsec); + font-size: 0.9rem; + font-weight: 600; + + + .form-group { + margin-top: 11px; + } +} + .form-group-label { font-weight: 600; padding-top: 6px; diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e61f792a6..abd555853 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1523,6 +1523,8 @@ ApplicationRatingPointsTip: Bewerber mit 5.0 werden garantiert nicht dem Kurs zu ApplicationRatingComment: Kommentar ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter +ApplicationRatingSection: Bewertung +ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren. AllocationSchoolShort: Institut Allocation: Zentralanmeldung diff --git a/routes b/routes index d801d285c..b8c14a9e7 100644 --- a/routes +++ b/routes @@ -86,7 +86,6 @@ / AShowR GET !free /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered - /application/#CryptoFileNameCourseApplication AApplicationR GET POST !timeANDself !lecturerANDstaff-time !selfANDread -- For Pattern Synonyms see Foundation @@ -165,7 +164,8 @@ /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: - /files CAFilesR GET !self !lecturerANDtime + / CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread + /files CAFilesR GET !self !lecturerANDstaff-time /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Foundation.hs b/src/Foundation.hs index 2d79722e1..5077ef4a5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -665,22 +665,6 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) return Authorized - AllocationR tid ssh ash (AApplicationR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID - isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation - E.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId) - E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId - guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) - return Authorized AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do @@ -750,20 +734,6 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of - CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course - allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation - - case allocation of - Nothing -> return () - Just Allocation{..} -> do - cTime <- liftIO getCurrentTime - guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) - guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo - - return Authorized - CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn @@ -872,6 +842,23 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of guard $ NTop (Just now) >= NTop deregUntil return Authorized _other -> unauthorizedI MsgUnauthorizedCourseTime + + CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do + Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course + allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation + + case allocation of + Nothing -> do + cTime <- liftIO getCurrentTime + guard $ maybe False (cTime >=) courseRegisterFrom + guard $ maybe True (cTime <=) courseRegisterTo + Just Allocation{..} -> do + cTime <- liftIO getCurrentTime + guard $ NTop allocationRegisterFrom <= NTop (Just cTime) + guard $ NTop (Just cTime) <= NTop allocationRegisterTo + + return Authorized AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do -- Checks `registerFrom` and `registerTo`, override as further routes become available @@ -891,6 +878,20 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of r -> $unsupportedAuthPredicate AuthTime r tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of + CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course + allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation + + case allocation of + Nothing -> return () + Just Allocation{..} -> do + cTime <- liftIO getCurrentTime + guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) + guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo + + return Authorized + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do -- Checks `registerFrom` and `registerTo`, override as further routes become available now <- liftIO getCurrentTime @@ -1203,10 +1204,6 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId return $ Right courseApplicationUser - AllocationR _ _ _ (AApplicationR cID) -> do - appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId - return $ Right courseApplicationUser _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route referencedUser <- case referencedUser' of Right uid -> return uid @@ -1757,7 +1754,6 @@ instance YesodBreadcrumbs UniWorX where mr <- getMessageRender Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR) - breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR) breadcrumb CourseListR = return ("Kurse" , Nothing) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) @@ -1783,6 +1779,8 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CApplicationR tid ssh csh _ CAEditR) = return ("Bewerbung", Just $ CourseR tid ssh csh CApplicationsR) + breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR) breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 2cf732df8..bc19f3dc2 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -4,9 +4,8 @@ module Handler.Allocation.Application , ApplicationForm(..) , ApplicationFormMode(..) , ApplicationFormException(..) - , applicationForm + , applicationForm, editApplicationR , postAApplyR - , getAApplicationR, postAApplicationR ) where import Import hiding (hash) @@ -71,20 +70,21 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception ApplicationFormException -applicationForm :: AllocationId +applicationForm :: (Maybe AllocationId) -> CourseId -> UserId -> ApplicationFormMode -- ^ Which parts of the shared form to display -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) -applicationForm aId cid uid ApplicationFormMode{..} csrf = do +applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do + (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do - mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] - coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId] + mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] + coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) course <- getJust cid [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid - E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId) + E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority) return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority return (mApplication, coursesNum, course, maxPrio) @@ -110,18 +110,20 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do } prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions - (prioRes, prioView) <- case (afmApplicant, afmApplicantEdit, mApp) of - (True , True , Nothing) + (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of + (True , True , True , Nothing) -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio) - (True , True , Just _ ) + (True , True , True , Just _ ) -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio - (True , False, _ ) + (True , True , False, _ ) -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio - (False, _ , Just _ ) + (True , False, _ , Just _ ) | is _Just oldPrio -> pure (FormSuccess oldPrio, Nothing) - _other + (True , _ , _ , _ ) -> throwM ApplicationFormNoApplication + (False, _ , _ , _ ) + -> pure (FormSuccess Nothing, Nothing) (fieldRes, fieldView') <- if | afmApplicantEdit || afmLecturer @@ -210,6 +212,15 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do ] (actionRes, buttonsView) <- buttonForm' buttons csrf + ratingSection <- if + | afmLecturer + , afmApplicantEdit + -> Just . set _fvTooltip (Just . toHtml $ mr MsgApplicationRatingSectionSelfTip) . snd <$> formSection MsgApplicationRatingSection + | afmLecturer + -> Just . snd <$> formSection MsgApplicationRatingSection + | otherwise + -> return Nothing + return ( ApplicationForm <$> prioRes <*> fieldRes @@ -227,7 +238,8 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do , filesLinkView , filesWarningView ] ++ maybe [] (map Just) filesView ++ - [ vetoView + [ ratingSection + , vetoView , pointsView , commentView ] @@ -238,7 +250,7 @@ applicationForm aId cid uid ApplicationFormMode{..} csrf = do -editApplicationR :: AllocationId +editApplicationR :: Maybe AllocationId -> UserId -> CourseId -> Maybe CourseApplicationId @@ -246,10 +258,10 @@ editApplicationR :: AllocationId -> (AllocationApplicationButton -> Bool) -> SomeRoute UniWorX -> Handler (ApplicationFormView, Enctype) -editApplicationR aId uid cid mAppId afMode allowAction postAction = do +editApplicationR maId uid cid mAppId afMode allowAction postAction = do Course{..} <- runDB $ get404 cid - ((appRes, appView), appEnc) <- runFormPost $ applicationForm aId cid uid afMode + ((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid uid afMode formResult appRes $ \ApplicationForm{..} -> do if @@ -258,7 +270,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do -> runDB $ do haveOld <- exists [ CourseApplicationCourse ==. cid , CourseApplicationUser ==. uid - , CourseApplicationAllocation ==. Just aId + , CourseApplicationAllocation ==. maId ] when haveOld $ invalidArgsI [MsgCourseApplicationExists] @@ -274,7 +286,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment - , courseApplicationAllocation = Just aId + , courseApplicationAllocation = maId , courseApplicationAllocationPriority = afPriority , courseApplicationTime = now , courseApplicationRatingTime = guardOn rated now @@ -328,7 +340,7 @@ editApplicationR aId uid cid mAppId afMode allowAction postAction = do , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment - , courseApplicationAllocation = Just aId + , courseApplicationAllocation = maId , courseApplicationAllocationPriority = afPriority } @@ -393,50 +405,6 @@ postAApplyR tid ssh ash cID = do , afmLecturer } - void . editApplicationR aId uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID + void . editApplicationR (Just aId) uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID invalidArgs ["Application form required"] - - -getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Html -getAApplicationR = postAApplicationR -postAApplicationR tid ssh ash cID = do - uid <- requireAuthId - appId <- decrypt cID - (Entity aId Allocation{..}, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do - alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash - app <- get404 appId - Just course <- getEntity $ courseApplicationCourse app - Just appUser <- get $ courseApplicationUser app - isAdmin <- exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool] - return (alloc, course, app, isAdmin, appUser) - - afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - afmApplicantEdit <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplicationR cID - courseCID <- encrypt cid :: Handler CryptoUUIDCourse - - let afMode = ApplicationFormMode - { afmApplicant = uid == courseApplicationUser || isAdmin - , afmApplicantEdit - , afmLecturer - } - - (ApplicationFormView{..}, appEnc) <- editApplicationR aId uid cid (Just appId) afMode (/= BtnAllocationApply) $ if - | uid == courseApplicationUser - -> SomeRoute $ AllocationR tid ssh ash AShowR :#: courseCID - | otherwise - -> SomeRoute . AllocationR tid ssh ash $ AApplicationR cID - - let title = MsgCourseApplicationTitle userDisplayName courseShorthand - - siteLayoutMsg title $ do - setTitleI title - - wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings - { formMethod = POST - , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AApplicationR cID - , formEncoding = appEnc - , formAttrs = [] - , formSubmit = FormNoSubmit - , formAnchor = Nothing :: Maybe Text - } diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 0cc4d455b..b31ae9273 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -71,15 +71,17 @@ getAShowR tid ssh ash = do cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid $ ApplicationFormMode True mayApply isLecturer - subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId + mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer + tRoute <- case mApp of + Nothing -> return . AllocationR tid ssh ash $ AApplyR cID + Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR let mApplyFormView' = view _1 <$> mApplyFormView overrideVisible = not mayApply && is _Just mApp case mApplyFormView of Just (_, appFormEnctype) -> wrapForm $(widgetFile "allocation/show/course") FormSettings { formMethod = POST - , formAction = Just . SomeRoute $ AllocationR tid ssh ash subRoute + , formAction = Just $ SomeRoute tRoute , formEncoding = appFormEnctype , formAttrs = [ ("class", "allocation-course") ] diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs index bcb5146a1..d22c299cc 100644 --- a/src/Handler/Course/Application.hs +++ b/src/Handler/Course/Application.hs @@ -4,3 +4,4 @@ module Handler.Course.Application import Handler.Course.Application.List as Handler.Course.Application import Handler.Course.Application.Files as Handler.Course.Application +import Handler.Course.Application.Edit as Handler.Course.Application diff --git a/src/Handler/Course/Application/Edit.hs b/src/Handler/Course/Application/Edit.hs new file mode 100644 index 000000000..281a21826 --- /dev/null +++ b/src/Handler/Course/Application/Edit.hs @@ -0,0 +1,55 @@ +module Handler.Course.Application.Edit + ( getCAEditR, postCAEditR + ) where + +import Import + +import Handler.Utils +import Handler.Allocation.Application + + +getCAEditR, postCAEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler Html +getCAEditR = postCAEditR +postCAEditR tid ssh csh cID = do + uid <- requireAuthId + appId <- decrypt cID + (mAlloc, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do + course <- getBy404 $ TermSchoolCourseShort tid ssh csh + app <- get404 appId + mAlloc <- traverse getEntity404 $ courseApplicationAllocation app + appUser <- get404 $ courseApplicationUser app + isAdmin <- case mAlloc of + Just alloc -> exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool] + Nothing -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool] + return (mAlloc, course, app, isAdmin, appUser) + + afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + afmApplicantEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR + courseCID <- encrypt cid :: Handler CryptoUUIDCourse + + let afMode = ApplicationFormMode + { afmApplicant = uid == courseApplicationUser || isAdmin + , afmApplicantEdit + , afmLecturer + } + + (ApplicationFormView{..}, appEnc) <- editApplicationR (entityKey <$> mAlloc) uid cid (Just appId) afMode (/= BtnAllocationApply) $ if + | uid == courseApplicationUser + , Just (Entity _ Allocation{..}) <- mAlloc + -> SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: courseCID + | otherwise + -> SomeRoute $ CApplicationR tid ssh csh cID CAEditR + + let title = MsgCourseApplicationTitle userDisplayName courseShorthand + + siteLayoutMsg title $ do + setTitleI title + + wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ CApplicationR tid ssh csh cID CAEditR + , formEncoding = appEnc + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Nothing :: Maybe Text + } diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 966e29a44..84867c817 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -116,7 +116,7 @@ postCApplicationsR tid ssh csh = do appId <- view $ resultCourseApplication . _entityKey cID <- encrypt appId - guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR -- TODO: replace with CAShowR + guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR view id diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet index 844821fa2..c492b61d7 100644 --- a/templates/widgets/aform/aform.hamlet +++ b/templates/widgets/aform/aform.hamlet @@ -11,6 +11,9 @@ $case formLayout $if fvId view == idFormSectionNoinput

^{fvLabel view} + $maybe hint <- fvTooltip view +
+ ^{hint} $elseif fvId view == idFormMessageNoinput
^{fvInput view} From cf0ec1aec4267b99cf549b8ae5a0cd1762c45884 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 26 Aug 2019 17:55:05 +0200 Subject: [PATCH 03/13] feat(course-applications): csv transport --- messages/uniworx/de.msg | 24 ++ src/Data/Bool/Instances.hs | 28 +++ src/Data/CryptoID/Instances.hs | 11 + src/Handler/Course/Application/List.hs | 329 ++++++++++++++++++++++++- src/Handler/Exam/Users.hs | 43 ++-- src/Handler/Utils.hs | 8 + src/Import/NoModel.hs | 6 + src/Utils/Csv.hs | 7 +- 8 files changed, 425 insertions(+), 31 deletions(-) create mode 100644 src/Data/Bool/Instances.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index abd555853..737f60890 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1411,6 +1411,18 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserCourseNote: Notizen zum Teilnehmer +CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist +CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien) +CsvColumnApplicationsName: Voller Name des Bewerbers +CsvColumnApplicationsMatriculation: Matrikelnummer des Bewerbers +CsvColumnApplicationsField: Studienfach, mit dem der Bewerber seine Bewerbung assoziiert hat +CsvColumnApplicationsDegree: Abschluss, den der Bewerber im assoziierten Studienfach anstrebt +CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studienfach +CsvColumnApplicationsText: Text-Bewerbung +CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)? +CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer +CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" +CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber Action: Aktion @@ -1433,6 +1445,15 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden +CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern +CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen +CourseApplicationsTableCsvSetRating: Bewertung eintragen +CourseApplicationsTableCsvSetComment: Bewertungskommentar eintragen + +CourseApplicationsTableCsvExceptionNoMatchingUser: Bewerber konnte nicht eindeutig identifiziert werden +CourseApplicationsTableCsvExceptionNoMatchingAllocation: Zentralanmeldung konnte nicht eindeutig identifiziert werden +CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden + TableHeadingFilter: Filter TableHeadingCsvImport: CSV-Import TableHeadingCsvExport: CSV-Export @@ -1536,6 +1557,9 @@ CourseApplicationsListTitle: Bewerbungen CourseApplicationId: Bewerbungsnummer CourseApplicationRatingPoints: Bewertung CourseApplicationVeto: Veto +CourseApplicationNoVeto: Kein Veto +CourseApplicationNoRatingPoints: Keine Bewertung +CourseApplicationNoRatingComment: Kein Kommentar UserDisplayName: Voller Name UserMatriculation: Matrikelnummer \ No newline at end of file diff --git a/src/Data/Bool/Instances.hs b/src/Data/Bool/Instances.hs new file mode 100644 index 000000000..699ad1b38 --- /dev/null +++ b/src/Data/Bool/Instances.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Bool.Instances + () where + +import ClassyPrelude + +import qualified Data.Csv as Csv +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import qualified Data.Text as Text + + +instance Csv.ToField Bool where + toField True = "t" + toField False = "f" + +instance Csv.FromField Bool where + parseField f = do + (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f + (True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool" + where + isTrue f' = any (== f') + [ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] + isFalse f' = any (== f') + [ "no", "n", "nein", "falsch", "f", "false", "0" ] diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index bc66cb874..0867f60b5 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -16,6 +16,8 @@ import qualified Data.CaseInsensitive as CI import Web.PathPieces import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..)) +import qualified Data.Csv as Csv + instance ToMarkup s => ToMarkup (CID.CryptoID c s) where toMarkup = toMarkup . CID.ciphertext @@ -34,3 +36,12 @@ instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c ( instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece + +instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where + parseField = fmap CID.CryptoID . Csv.parseField + +instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where + toField = Csv.toField . CID.ciphertext + +instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where + toField = Csv.toField . CI.foldedCase . CID.ciphertext diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 84867c817..bd33a3b88 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Handler.Course.Application.List ( getCApplicationsR, postCApplicationsR ) where @@ -8,8 +10,21 @@ import Handler.Utils import Handler.Utils.Table.Columns 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 Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import qualified Data.Map as Map + +import qualified Data.Conduit.List as C + type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication) `E.InnerJoin` E.SqlExpr (Entity User) @@ -76,6 +91,122 @@ resultStudyTerms = _dbrOutput . _6 . _Just resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _7 . _Just + +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 $ any (== 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 + + getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCApplicationsR = postCApplicationsR postCApplicationsR tid ssh csh = do @@ -184,8 +315,202 @@ postCApplicationsR tid ssh csh = do } dbtParams = def - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing + dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv + dbtCsvEncode = DictJust . C.mapM . runReaderT $ 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 ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + CourseApplicationsTableCsvSetVetoData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + CourseApplicationsTableCsvSetRatingData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + CourseApplicationsTableCsvSetCommentData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment ] + 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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 6bd06b1b5..692a69c3c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -30,7 +30,6 @@ import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI import Numeric.Lens (integral) -import Control.Arrow (Kleisli(..)) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) @@ -123,23 +122,20 @@ instance ToNamedRecord ExamUserTableCsv where instance FromNamedRecord ExamUserTableCsv where parseNamedRecord csv -- Manually defined awaiting issue #427 = ExamUserTableCsv - <$> csv .:? "surname" - <*> csv .:? "first-name" - <*> csv .:? "name" - <*> csv .:? "matriculation" - <*> csv .:? "field" - <*> csv .:? "degree" - <*> csv .:? "semester" - <*> csv .:? "occurrence" - <*> csv .:? "exercise-points" - <*> csv .:? "exercise-num-passes" - <*> csv .:? "exercise-points-max" - <*> csv .:? "exercise-num-passes-max" - <*> csv .:? "exam-result" - <*> csv .:? "course-note" - where - (.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a) - m .:? name = Csv.lookup m name <|> return Nothing + <$> csv .:?? "surname" + <*> csv .:?? "first-name" + <*> csv .:?? "name" + <*> csv .:?? "matriculation" + <*> csv .:?? "field" + <*> csv .:?? "degree" + <*> csv .:?? "semester" + <*> csv .:?? "occurrence" + <*> csv .:?? "exercise-points" + <*> csv .:?? "exercise-num-passes" + <*> csv .:?? "exercise-points-max" + <*> csv .:?? "exercise-num-passes-max" + <*> csv .:?? "exam-result" + <*> csv .:?? "course-note" instance DefaultOrdered ExamUserTableCsv where headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions @@ -567,14 +563,6 @@ postEUsersR tid ssh csh examn = do , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text } where - studyFeaturesWidget :: StudyFeaturesId -> Widget - studyFeaturesWidget featId = do - (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) - [whamlet| - $newline never - _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} - |] - registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where @@ -644,7 +632,6 @@ postEUsersR tid ssh csh examn = do _ -> isActive 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)] - E.limit 2 -- we just need to know whether there is a unique one, none, or more than one return $ studyFeatures E.^. StudyFeaturesId case studyFeatures of [E.Value fid] -> return $ Just fid @@ -657,7 +644,7 @@ postEUsersR tid ssh csh examn = do | Just (Entity _ CourseParticipant{..}) <- oldFeatures , Just sfid <- courseParticipantField , E.Value sfid `elem` studyFeatures - -> return Nothing + -> return $ Just sfid _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 21f140921..0d181cbbd 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -225,3 +225,11 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc f <- messageLoggerSource app <$> readTVarIO loggerTVar f loc src lvl str +studyFeaturesWidget :: StudyFeaturesId -> Widget +studyFeaturesWidget featId = do + (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) + [whamlet| + $newline never + _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} + |] + diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ea3a99691..ae9092732 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -14,6 +14,7 @@ import ClassyPrelude.Yesod as Import , static , boolField, identifyForm , HasHttpManager(..) + , embed ) import Model.Types.TH.JSON as Import @@ -128,6 +129,7 @@ import Net.IP.Instances as Import () import Data.Void.Instances as Import () import Crypto.Hash.Instances as Import () import Colonnade.Instances as Import () +import Data.Bool.Instances as Import () import Control.Lens as Import hiding ( (<.>) @@ -138,6 +140,10 @@ import Control.Lens as Import import Control.Lens.Extras as Import (is) import Data.Set.Lens as Import +import Control.Arrow as Import (Kleisli(..)) + +import Control.Monad.Morph as Import + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 0205eab4f..e864f9e04 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -1,8 +1,9 @@ module Utils.Csv ( pathPieceCsv + , (.:??) ) where -import ClassyPrelude +import ClassyPrelude hiding (lookup) import Data.Csv hiding (Name) import Language.Haskell.TH (Name) @@ -17,3 +18,7 @@ pathPieceCsv (conT -> t) = instance FromField $(t) where parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField |] + + +(.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a) +m .:?? name = lookup m name <|> return Nothing From 33d217519867ff59b16cdcfbeb00313d697f37f4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 26 Aug 2019 19:17:03 +0200 Subject: [PATCH 04/13] refactor: hlint --- src/Data/Bool/Instances.hs | 4 ++-- src/Handler/Course/Application/Files.hs | 2 +- src/Import/NoModel.hs | 4 +--- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Data/Bool/Instances.hs b/src/Data/Bool/Instances.hs index 699ad1b38..d5eb7a2e0 100644 --- a/src/Data/Bool/Instances.hs +++ b/src/Data/Bool/Instances.hs @@ -22,7 +22,7 @@ instance Csv.FromField Bool where (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f (True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool" where - isTrue f' = any (== f') + isTrue = flip elem [ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] - isFalse f' = any (== f') + isFalse = flip elem [ "no", "n", "nein", "falsch", "f", "false", "0" ] diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index fc42b8e39..31ec53e47 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -96,7 +96,7 @@ getCAppsFilesR tid ssh csh = do E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId return file - yield $ File + yield File { fileModified = courseApplicationTime , fileTitle = mkAppDir "" , fileContent = Nothing diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ae9092732..598c8479b 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -72,7 +72,7 @@ import Ldap.Client.Pool as Import import System.Random as Import (Random(..)) import Control.Monad.Random.Class as Import (MonadRandom(..)) -import Control.Monad.Morph as Import (MFunctor(..)) +import Control.Monad.Morph as Import import Control.Monad.Trans.Resource as Import (ReleaseKey) import Jose.Jwt as Import (Jwt) @@ -142,8 +142,6 @@ import Data.Set.Lens as Import import Control.Arrow as Import (Kleisli(..)) -import Control.Monad.Morph as Import - import Control.Monad.Trans.RWS (RWST) From 00a6ca83bcc096075b65a70cf18860c1d7bf5a6b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 08:51:02 +0200 Subject: [PATCH 05/13] fix(course-edit): only show allocation error message when relevant --- messages/uniworx/de.msg | 2 +- src/Handler/Course/Edit.hs | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 737f60890..8568ce0e3 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -211,7 +211,7 @@ 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 +AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden. Ihre Änderungen wurden ignoriert. CourseFormSectionRegistration: Anmeldung zum Kurs diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index ce9d0e422..248c17571 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -541,7 +541,15 @@ upsertAllocationCourse cid cfAllocation = do -> return True | Just Allocation{allocationStaffRegisterTo} <- prevAllocation , NTop allocationStaffRegisterTo <= NTop (Just now) - -> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired + -> let anyChanges + | Just AllocationCourseForm{..} <- cfAllocation + , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse + = or [ acfAllocation /= allocationCourseAllocation + , acfMinCapacity /= allocationCourseMinCapacity + ] + | otherwise + = True + in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired) | otherwise -> return True From ef3de5d2e35b765aa80130ebf5929c9a8b66e5be Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 08:53:04 +0200 Subject: [PATCH 06/13] chore(changelog): update changelog --- templates/i18n/changelog/de.hamlet | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index d2c436d00..ad9295da7 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,5 +1,10 @@ $newline never
+
+
+
    +
  • Bewertung von Kurs-Bewerbungen via CSV +
    19.08.2019
      From d3fdc40978767057364afc0f6f93c0feedbf9fd2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 08:57:34 +0200 Subject: [PATCH 07/13] chore(release): 5.4.0 --- CHANGELOG.md | 16 ++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 19 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 40171cfc0..89697aa7f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,22 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [5.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.3.0...v5.4.0) (2019-08-27) + + +### Bug Fixes + +* **course-edit:** only show allocation error message when relevant ([00a6ca8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/00a6ca8)) + + +### Features + +* **allocations:** serve archive of all application files by course ([5e393c5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5e393c5)) +* allow editing of course applications outside of allocation ([e816a30](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e816a30)) +* **course-applications:** csv transport ([cf0ec1a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf0ec1a)) + + + ## [5.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.2.3...v5.3.0) (2019-08-22) diff --git a/package-lock.json b/package-lock.json index 122cd9ca6..444fbd059 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.3.0", + "version": "5.4.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 747185adc..d2a34c8a2 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.3.0", + "version": "5.4.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index ac24edf65..b1ac3455e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 5.3.0 +version: 5.4.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From c2e13cf4df1fc8a6e0d919b5171a7eaf002fd381 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 09:34:04 +0200 Subject: [PATCH 08/13] feat: optional ribbon --- config/settings.yml | 1 + src/Foundation.hs | 2 ++ src/Settings.hs | 3 +++ start.sh | 1 + templates/default-layout.hamlet | 4 ++++ templates/default-layout.lucius | 24 ++++++++++++++++++++++++ 6 files changed, 35 insertions(+) diff --git a/config/settings.yml b/config/settings.yml index 9d787ed7f..ca2520708 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -122,3 +122,4 @@ user-defaults: warning-days: 1209600 instance-id: "_env:INSTANCE_ID:instance" +ribbon: "_env:RIBBON:" diff --git a/src/Foundation.hs b/src/Foundation.hs index 5077ef4a5..1852150ac 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1664,6 +1664,8 @@ siteLayout' headingOverride widget = do hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes + contentRibbon :: Maybe Widget + contentRibbon = fmap toWidget appRibbon MsgRenderer mr <- getMsgRenderer let diff --git a/src/Settings.hs b/src/Settings.hs index 7bec37cb8..7e99cae3a 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -138,6 +138,7 @@ data AppSettings = AppSettings , appAuthPWHash :: PWHashConf , appInitialInstanceID :: Maybe (Either FilePath UUID) + , appRibbon :: Maybe Text } deriving (Show) data LogSettings = LogSettings @@ -419,6 +420,8 @@ instance FromJSON AppSettings where _ -> return () return val' + appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon" + return AppSettings {..} makeClassy_ ''AppSettings diff --git a/start.sh b/start.sh index a9ef7cb8d..ffe083bea 100755 --- a/start.sh +++ b/start.sh @@ -10,6 +10,7 @@ export LOG_ALL=${LOG_ALL:-false} export LOGLEVEL=${LOGLEVEL:-info} export DUMMY_LOGIN=${DUMMY_LOGIN:-true} export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true} +export RIBBON=${RIBBON:-Localhost} move-back() { mv -v .stack-work .stack-work-run diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 21ac81042..cdcffaad5 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -5,6 +5,10 @@ $if not isModal ^{navbar} + $maybe ribbon <- contentRibbon +
      + ^{ribbon} +
      diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index b3b493fd5..99dd61366 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -694,3 +694,27 @@ section { .form--inline { display: inline-block; } + + +.ribbon { + position: fixed; + top: calc(40px + var(--header-height)); + right: -63px; + transform: rotate(45deg); + width: 250px; + background: var(--color-error); + text-align: center; + color: var(--color-lightwhite); + font-weight: 600; + font-size: 1.25rem; + line-height: 2em; + box-shadow: 0 0 3px rgba(0, 0, 0, 0.4); + z-index: 19; + pointer-events: none; +} + +@media (max-height: 500px) { + .ribbon { + top: calc(25px + var(--header-height-collapsed)); + } +} From 336f9b57999cf425ddda9ddf234831ffccad7bab Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 09:45:30 +0200 Subject: [PATCH 09/13] style(ribbon): responsiveness --- templates/default-layout.lucius | 7 +++++-- templates/widgets/navbar/navbar.lucius | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 99dd61366..44baa25d9 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -699,6 +699,7 @@ section { .ribbon { position: fixed; top: calc(40px + var(--header-height)); + transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1); right: -63px; transform: rotate(45deg); width: 250px; @@ -713,8 +714,10 @@ section { pointer-events: none; } -@media (max-height: 500px) { +@media (max-width: 768px) { .ribbon { - top: calc(25px + var(--header-height-collapsed)); + top: calc(20px + var(--header-height-collapsed)); + right: -83px; + transform: rotate(45deg) scale(0.6); } } diff --git a/templates/widgets/navbar/navbar.lucius b/templates/widgets/navbar/navbar.lucius index ce25a3588..c3885f975 100644 --- a/templates/widgets/navbar/navbar.lucius +++ b/templates/widgets/navbar/navbar.lucius @@ -10,6 +10,7 @@ width: 20px; z-index: 50; background-image: linear-gradient(to left, rgba(0, 0, 0, 0.4), transparent); + transition: height .2s cubic-bezier(0.03, 0.43, 0.58, 1); } @media (min-width: 768px) { From 52a88f8fadcc6a115a569842197fa0b06367c368 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 09:46:36 +0200 Subject: [PATCH 10/13] fix(changelog): add date --- templates/i18n/changelog/de.hamlet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/i18n/changelog/de.hamlet b/templates/i18n/changelog/de.hamlet index ad9295da7..5031e21ef 100644 --- a/templates/i18n/changelog/de.hamlet +++ b/templates/i18n/changelog/de.hamlet @@ -1,6 +1,6 @@ $newline never
      -
      +
      27.08.2019
      • Bewertung von Kurs-Bewerbungen via CSV From c2c6974a7700e4d9bad92c4477f64ad2b1eed5a2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 10:09:58 +0200 Subject: [PATCH 11/13] fix(course-applications-csv): record rating time --- src/Handler/Course/Application/List.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index bd33a3b88..a3faa9a89 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -367,18 +367,27 @@ postCApplicationsR tid ssh csh = do CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment , dbtCsvCoarsenActionClass = const DBCsvActionExisting , dbtCsvExecuteActions = do + now <- liftIO getCurrentTime C.mapM_ $ \case CourseApplicationsTableCsvSetFieldData{..} -> do - CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField ] + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField + , CourseApplicationTime =. now + ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetVetoData{..} -> do - CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto ] + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto + , CourseApplicationRatingTime =. Just now + ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetRatingData{..} -> do - CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating ] + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating + , CourseApplicationRatingTime =. Just now + ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetCommentData{..} -> do - CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment ] + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment + , CourseApplicationRatingTime =. Just now + ] audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication return $ CourseR tid ssh csh CApplicationsR , dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case From 857beac1c2622f7d179f006c76704512eef502b0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 10:14:44 +0200 Subject: [PATCH 12/13] chore: don't limit number of cores used for build --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index b1ac3455e..38bead9aa 100644 --- a/package.yaml +++ b/package.yaml @@ -194,7 +194,7 @@ ghc-options: - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - - -j3 + - -j when: - condition: flag(pedantic) From c313ba8097bad6dce154f12ef2b1a5b65617ac04 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Aug 2019 10:28:53 +0200 Subject: [PATCH 13/13] chore(release): 5.5.0 --- CHANGELOG.md | 15 +++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 89697aa7f..6b2b815ec 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [5.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.4.0...v5.5.0) (2019-08-27) + + +### Bug Fixes + +* **changelog:** add date ([52a88f8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/52a88f8)) +* **course-applications-csv:** record rating time ([c2c6974](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2c6974)) + + +### Features + +* optional ribbon ([c2e13cf](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c2e13cf)) + + + ## [5.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v5.3.0...v5.4.0) (2019-08-27) diff --git a/package-lock.json b/package-lock.json index 444fbd059..0ffdeb526 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.4.0", + "version": "5.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d2a34c8a2..29d364513 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "5.4.0", + "version": "5.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 38bead9aa..cdeca6c8f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 5.4.0 +version: 5.5.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage