diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 5a4cef6b6..b0e631340 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -36,6 +36,7 @@ TutorialDelete: Löschen TutorialsHeading: Kurse TutorialNew: Neuer Kurs TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Kurs #{tutn} angemeldet +TutorialRegisteredFail tutn@TutorialName: Anmeldung zum Kurs #{tutn} fehlgeschlagen. Existiert bereits eine Anmeldung? TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Kurs #{tutn} abgemeldet MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{tid}-#{ssh}-#{csh}] Einladung zum Ausbilder für #{tutn} TutorInviteHeading tutn@TutorialName: Einladung zum Ausbilder/zur Ausbilderin für #{tutn} diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 20df36d50..a3afdf94f 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -36,6 +36,7 @@ TutorialDelete: Delete TutorialsHeading: Courses TutorialNew: New course TutorialRegisteredSuccess tutn: Successfully registered for the course #{tutn} +TutorialRegisteredFail tutn: Registering for the course #{tutn} failed. Probably already registered? TutorialDeregisteredSuccess tutn: Successfully de-registered for the course #{tutn} MailSubjectTutorInvitation tid ssh csh tutn: [#{tid}-#{ssh}-#{csh}] Invitation to be a instructor for #{tutn} TutorInviteHeading tutn: Invitation to be instructor for #{tutn} diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 8597a7c2c..5e658cb43 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -80,6 +80,7 @@ TableCompanyFilter: Firma oder Nummer TableCompanyShort: Firmenkürzel TableCompanies: Firmen TablePrimeCompany: Primäre Firma +TableBookingCompany: Buchende Firma TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyUser: Firmenangehöriger diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index d489426c1..97d3ba9cc 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -80,6 +80,7 @@ TableCompanyFilter: Company/Nr TableCompanyShort: Company shorthand TableCompanies: Companies TablePrimeCompany: Primary company +TableBookingCompany: Booking company TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyUser: Associate diff --git a/models/tutorials.model b/models/tutorials.model index e7e21e8b2..173f7862c 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -27,6 +27,7 @@ Tutor TutorialParticipant tutorial TutorialId OnDeleteCascade OnUpdateCascade user UserId + company CompanyId Maybe UniqueTutorialParticipant tutorial user deriving Eq Ord Show deriving Generic \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3052f652f..152d506ae 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -49,7 +49,6 @@ module Database.Esqueleto.Utils , unKey , subSelectCountDistinct , selectCountRows, selectCountDistinct - , selectMaybe , str2text, str2text' , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes @@ -739,8 +738,9 @@ selectCountDistinct q = do _other -> error "E.countDistinct did not return exactly one result" -selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) -selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) +-- DEPRECATED: use Database.Esqueleto.selectOne instead +-- selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) +-- selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) -- | convert something that is like a text to text str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 0243b0609..7e0812297 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -38,7 +38,7 @@ import Handler.Utils.I18n import Handler.Utils.Routes import Utils.Course (courseIsVisible) import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..)) - + import qualified Data.Set as Set import qualified Data.Aeson as JSON import qualified Data.HashSet as HashSet @@ -95,7 +95,7 @@ instance Exception InvalidAuthTag type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult - + data AccessPredicate = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) @@ -174,7 +174,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do v <- mkV memcachedBySet mExp k v either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v - + -- cacheAP' :: ( Binary k -- , Typeable v, Binary v -- ) @@ -185,7 +185,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do -- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of -- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV -- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing - + cacheAPDB' :: ( Binary k , Typeable v, Binary v, NFData v ) @@ -538,14 +538,14 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of +tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of ForProfileR cID -> checkSupervisor (mAuthId, cID) ForProfileDataR cID -> checkSupervisor (mAuthId, cID) FirmAllR -> checkAnySupervisor mAuthId FirmUsersR fsh -> checkCompanySupervisor (mAuthId, fsh) FirmSupersR fsh -> checkCompanySupervisor (mAuthId, fsh) - r -> $unsupportedAuthPredicate AuthSupervisor r - where + r -> $unsupportedAuthPredicate AuthSupervisor r + where checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID @@ -553,13 +553,13 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) return Authorized checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) return Authorized checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId] guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor) return Authorized @@ -692,7 +692,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture _ | is _Nothing mAuthId' -> return AuthenticationRequired CourseR{} -> unauthorizedI MsgUnauthorizedLecturer EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer - _other -> unauthorizedI MsgUnauthorizedSchoolLecturer + _other -> unauthorizedI MsgUnauthorizedSchoolLecturer | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -722,7 +722,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture return Authorized where mkLecturerList _ route _ = case route of - CourseR{} -> cacheLecturerList + CourseR{} -> cacheLecturerList EExamR{} -> Just ( AuthCacheExternalExamStaffList , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser) @@ -1199,7 +1199,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case rout guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam return Authorized CSheetR tid ssh csh shn _ -> exceptT return return $ do - requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do + requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectOne . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -1700,7 +1700,7 @@ evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] - evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId evalAccessWithFor assumptions mAuthId route isWrite - + evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB = evalAccessWith diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index bcd9f152a..367fe7a21 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1988,7 +1988,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLabel = MsgMenuSheetPersonalisedFiles , navRoute = CSheetR tid ssh csh shn SPersonalFilesR , navAccess' = NavAccessDB $ - let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do + let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectOne . E.from $ \(sheet `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_$ sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseTerm E.==. E.val tid diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index c000c9c2b..538d4d68a 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -13,6 +13,7 @@ import Import import Handler.Utils import Handler.Utils.Avs +import Handler.Utils.Company import Jobs.Queue @@ -401,6 +402,7 @@ registerTutorialMembers :: TutorialId -> Set UserId -> Handler () registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do + tutorialParticipantCompany <- selectCompanyUserPrime' tutorialParticipantUser Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } [] audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser return tutPartId diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index b8a04f31e..3d66e30c7 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -18,6 +18,7 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Company import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E import Database.Esqueleto.Utils.TH @@ -733,9 +734,12 @@ postCUsersR tid ssh csh = do addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterTutorialData{..}, selectedUsers) -> do - runDB . forM_ selectedUsers $ - void . insertUnique . TutorialParticipant registerTutorial - addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers + Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do + fsh <- selectCompanyUserPrime' uid + mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh + return $ Sum $ length mbKey + let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers + addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterExamData{..}, selectedUsers) -> do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 34277e5cb..4d5d5e958 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -23,7 +23,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -419,7 +419,7 @@ examTemplate cid = runMaybeT $ do E.limit 1 E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] return (course, exam, authorshipStatementDefinition) - + extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] [] oldTerm <- MaybeT . get $ courseTerm oldCourse @@ -517,7 +517,7 @@ validateExam cId oldExam = do .| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId) - mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do + mSchool <- liftHandler . runDB . E.selectOne . E.from $ \(course `E.InnerJoin` school) -> do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseId E.==. E.val cId return school diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 29b27e86b..db154a960 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -59,6 +59,8 @@ type DailyTableExpr = `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) ) +type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) +type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity TutorialParticipant, Entity User, E.Value (Maybe CompanyId)) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlIJproj 4 1) @@ -66,23 +68,29 @@ queryCourse = $(sqlIJproj 4 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) queryTutorial = $(sqlIJproj 4 2) +queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) +queryParticipant = $(sqlIJproj 4 3) + queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 4 4) - -type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity User, E.Value (Maybe CompanyId)) - resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 +resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) +resultParticipant = _dbrOutput . _3 + +-- resultCompanyId :: Traversal' DailyTableData CompanyId +-- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just + resultUser :: Lens' DailyTableData (Entity User) -resultUser = _dbrOutput . _3 +resultUser = _dbrOutput . _4 resultCompanyId :: Traversal' DailyTableData CompanyId -resultCompanyId = _dbrOutput . _4 . _unValue . _Just +resultCompanyId = _dbrOutput . _5 . _unValue . _Just instance HasEntity DailyTableData User where hasEntity = resultUser @@ -93,7 +101,7 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do let - dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) + dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial @@ -105,7 +113,7 @@ mkDailyTable isAdmin ssh nd = do E.where_ $ trm E.^. TermId E.==. crs E.^. CourseTerm E.&&. E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) ) - return (crs, tut, usr, selectCompanyUserPrime usr) + return (crs, tut, tpu, usr, selectCompanyUserPrime usr) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat @@ -117,15 +125,17 @@ mkDailyTable isAdmin ssh nd = do tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid + , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserMatriclenr queryUser - , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) - , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) - , ("user-company", SortColumn $ queryUser >>> selectCompanyUserPrime) + , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) + , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs index 08830b584..40bdded68 100644 --- a/src/Handler/Sheet/Download.hs +++ b/src/Handler/Sheet/Download.hs @@ -66,7 +66,7 @@ getSArchiveR tid ssh csh shn = do | otherwise = f & _FileReference . _1 . _fileReferenceTitle %~ (unpack (mr $ SheetArchiveFileTypeDirectory (sft f)) ) sftDirectories <- if | not multipleSFTs -> return mempty - | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do + | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectOne . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do E.on $ sFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet E.&&. sFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType E.&&. sFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle @@ -78,7 +78,7 @@ getSArchiveR tid ssh csh shn = do [ sFile E.?. SheetFileModified , psFile E.?. PersonalisedSheetFileModified ] - + serveZipArchive archiveName $ do forM_ sftDirectories $ \(sft, mTime) -> yield . Left $ SheetFile { sheetFileType = sft diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 62a25cf60..1bdc42880 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -128,7 +128,7 @@ getSShowR tid ssh csh shn = do [ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR , wouldHaveReadAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR ] - mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do + mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectOne . E.from $ \(exam `E.InnerJoin` course) -> do E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.where_ $ exam E.^. ExamId E.==. E.val eId return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName) diff --git a/src/Handler/Tutorial/Register.hs b/src/Handler/Tutorial/Register.hs index 06471ead8..0377aae60 100644 --- a/src/Handler/Tutorial/Register.hs +++ b/src/Handler/Tutorial/Register.hs @@ -9,6 +9,7 @@ module Handler.Tutorial.Register import Import import Handler.Utils import Handler.Utils.Tutorial +import Handler.Utils.Company postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler () @@ -21,8 +22,12 @@ postTRegisterR tid ssh csh tutn = do formResult btnResult $ \case BtnRegister -> do - runDB . void . insert $ TutorialParticipant tutid uid - addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName + ok <- runDB $ do + fsh <- selectCompanyUserPrime' uid + insertUnique $ TutorialParticipant tutid uid fsh + if isJust ok + then addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName + else addMessageI Error $ MsgTutorialRegisteredFail tutorialName -- cannot happen, but it is nonetheless better to be safe than crashing redirect $ CourseR tid ssh csh CShowR BtnDeregister -> do runDB . deleteBy $ UniqueTutorialParticipant tutid uid diff --git a/src/Handler/Utils/AuthorshipStatement.hs b/src/Handler/Utils/AuthorshipStatement.hs index 2832bdd86..ddc455e1a 100644 --- a/src/Handler/Utils/AuthorshipStatement.hs +++ b/src/Handler/Utils/AuthorshipStatement.hs @@ -18,7 +18,7 @@ import qualified Data.Map.Strict as Map import Handler.Utils.Form (i18nLangMap, I18nLang(..)) import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Utils as E import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteArray as BA @@ -81,7 +81,7 @@ getSheetAuthorshipStatement :: MonadIO m => Entity Sheet -> SqlReadT m (Maybe (Entity AuthorshipStatementDefinition)) getSheetAuthorshipStatement (Entity _ Sheet{..}) = withCompatibleBackend @SqlBackend $ traverse getJustEntity <=< runMaybeT $ do - Entity _ School{..} <- MaybeT . E.selectMaybe . E.from $ \(school `E.InnerJoin` course) -> do + Entity _ School{..} <- MaybeT . E.selectOne . E.from $ \(school `E.InnerJoin` course) -> do E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool E.where_ $ course E.^. CourseId E.==. E.val sheetCourse return school diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index c8dad2968..ffa2f015f 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -251,8 +251,19 @@ getCompanyUserMaxPrio uid = do -- | retrieve maximum company user priority for a user within SQL query -- Note: if there a multiple top-companies, only one is returned selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId)) -selectCompanyUserPrime usr = E.subSelect $ do +selectCompanyUserPrime usr = E.subSelect $ selectCompanyUserPrimeHelper $ usr E.^. UserId + +-- | like @selectCompanyUserPrime@, but directly usable, a simpler type to think about it `UserId -> DB (Maybe CompanyId)` +selectCompanyUserPrime' :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) + => UserId -> ReaderT backend m (Maybe CompanyId) +selectCompanyUserPrime' uid = fmap E.unValue <<$>> E.selectOne $ selectCompanyUserPrimeHelper $ E.val uid + +-- selectCompanyUserPrime'' :: UserId -> DB (Maybe CompanyId) +-- selectCompanyUserPrime'' uid = (userCompanyCompany . entityVal) <<$>> selectMaybe [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Asc UserCompanyCompany] + +selectCompanyUserPrimeHelper :: E.SqlExpr (E.Value UserId) -> E.SqlQuery (E.SqlExpr (E.Value CompanyId)) +selectCompanyUserPrimeHelper uid = do uc <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserId E.==. uc E.^. UserCompanyUser + E.where_ $ uc E.^. UserCompanyUser E.==. uid E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] return (uc E.^. UserCompanyCompany) \ No newline at end of file diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 07b777643..cd91cc79f 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -62,7 +62,7 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do let w = length chunk in liftIO $ observeSourcedChunk storage w Just lh -> do - chunkRes <- lookupLRUHandle lh k + chunkRes <- lookupLRUHandle lh k case chunkRes of Just (chunk, w) -> Just chunk <$ do $logDebugS "fileChunkARC" "Prewarm hit" @@ -74,7 +74,7 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do for_ mStorage $ \storage -> let w = length chunk in liftIO $ observeSourcedChunk storage w - + arc <- getsYesod appFileSourceARC case arc of Nothing -> getChunkDB @@ -97,7 +97,7 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do liftIO $ Just x <$ observeSourcedChunk StorageARC w - + sourceFileDB :: forall m. (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FileContentReference -> ConduitT () ByteString (SqlPersistT m) () @@ -119,7 +119,7 @@ sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlRe Nothing -> return Nothing Just start -> do let getChunkDB = cont (start, dbChunksize) . runMaybeT $ - let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold @@ -191,7 +191,7 @@ sourceFile' = sourceFile . view (_FileReference . _1) instance (YesodMail UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => ToMailPart UniWorX FileReference where toMailPart = toMailPart <=< liftHandler . runDBRead . withReaderT projectBackend . toPureFile . sourceFile' - + respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX) => Maybe UTCTime -> MimeType @@ -253,7 +253,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do forM_ relevantChunks $ \(chunkHash, offset, cLength) -> let retrieveChunk = \case Just (start, cLength') | cLength' > 0 -> do - let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB @@ -270,7 +270,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) ) | otherwise -> throwM SourceFilesContentUnavailable - + | otherwise -> return $ sendResponseStatus noContent204 () where @@ -281,7 +281,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do , requestedActionAlreadySucceeded = Nothing } -byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) +byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange) where byteRange' = case byteRange of @@ -293,7 +293,7 @@ byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange) ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) - + acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m') acceptFile fInfo = do let fileTitle = "." unpack (fileName fInfo) diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index 841082745..623285e93 100644 --- a/src/Handler/Utils/Term.hs +++ b/src/Handler/Utils/Term.hs @@ -16,7 +16,7 @@ import qualified Data.Set as Set import qualified Data.Sequence as Seq import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Utils as E import Utils.Term @@ -41,7 +41,7 @@ getCurrentTerm :: MonadIO m => SqlReadT m (Maybe TermId) -- ^ Current, generally active, term (i.e. `termIsActiveE` with `Nothing` as `maybeAuthId`) getCurrentTerm = do now <- liftIO getCurrentTime - fmap (fmap E.unValue) . E.selectMaybe . E.from $ \term -> do + fmap (fmap E.unValue) . E.selectOne . E.from $ \term -> do E.where_ . termIsActiveE (E.val now) E.nothing $ term E.^. TermId E.orderBy [E.desc $ term E.^. TermName] return $ term E.^. TermId @@ -64,7 +64,7 @@ getActiveTerms = do E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList fetchTermByCID :: ( MonadHandler m - , BackendCompatible SqlBackend backend + , BackendCompatible SqlBackend backend , PersistQueryRead backend, PersistUniqueRead backend ) => CourseId -> ReaderT backend m Term diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index edffdaef1..1760d37fe 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -704,7 +704,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamRegistrationUser ==. oldUserId ] do - collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do + collision <- E.selectOne . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId @@ -726,7 +726,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamPartResultUser ==. oldUserId ] do - collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do + collision <- E.selectOne . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId @@ -816,7 +816,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do - collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do + collision <- E.selectOne . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle @@ -852,7 +852,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) do - collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do + collision <- E.selectOne . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId @@ -870,6 +870,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) E.<&> E.val newUserId + E.<&> (tutorialParticipant E.^. TutorialParticipantCompany) ) (\_current _excluded -> []) deleteWhere [ TutorialParticipantUser ==. oldUserId ] diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index f44763c48..eaff72ba0 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -281,6 +281,7 @@ makeLenses_ ''CourseUserExamOfficeOptOut makeLenses_ ''CourseNewsFile makeLenses_ ''Tutorial +makeLenses_ ''TutorialParticipant makeLenses_ ''SessionFile diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 4e05a2d04..e30296c56 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -86,7 +86,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Just now , userTokensIssuedAfter = Just now - , userMatrikelnummer = Just 999 + , userMatrikelnummer = Just "99" , userEmail = "G.Kleen@campus.lmu.de" , userDisplayEmail = "gregor.kleen@ifi.lmu.de" , userDisplayName = "Gregor Kleen" @@ -292,7 +292,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Just 365 + , userMatrikelnummer = Just "365" , userEmail = "vaupel.sarah@campus.lmu.de" , userDisplayEmail = "vaupel.sarah@campus.lmu.de" , userDisplayName = "Sarah Vaupel" @@ -1075,7 +1075,7 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False - , tutorialTime = Occurrences + , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = Thursday @@ -1132,7 +1132,7 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False - , tutorialTime = Occurrences + , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList [ ExceptOccur @@ -1177,7 +1177,7 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False - , tutorialTime = Occurrences + , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList [ ExceptOccur @@ -1209,12 +1209,12 @@ fillDb = do insert_ $ CourseParticipant c gkleen now $ CourseParticipantInactive True insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False insert_ $ CourseParticipant c svaupel now CourseParticipantActive - insert_ $ TutorialParticipant tut1 svaupel - insert_ $ TutorialParticipant tut2 svaupel - when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel - insert_ $ TutorialParticipant tut1 gkleen - insert_ $ TutorialParticipant tut2 fhamann - when (even tyear) $ insert_ $ TutorialParticipant tut3 jost + insert_ $ TutorialParticipant tut1 svaupel Nothing + insert_ $ TutorialParticipant tut2 svaupel $ Just fraGround + when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel $ Just fraGround + insert_ $ TutorialParticipant tut1 gkleen $ Just nice + insert_ $ TutorialParticipant tut2 fhamann $ Just bpol + when (even tyear) $ insert_ $ TutorialParticipant tut3 jost $ Just fraportAg when (odd tyear) $ void . insert' $ Exam { examCourse = c