fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(daily): make company a property of TutorialParticipant, towards #90

Browse Source
This commit is contained in:
Steffen Jost 2024-09-16 17:16:19 +02:00
parent 6e3dd1c1f3
commit 53c68638da
22 changed files with 108 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/courses/tutorial/de-de-formal.msg
View File

@ -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}

1
messages/uniworx/categories/courses/tutorial/en-eu.msg
View File

@ -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}

1
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -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

1
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -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

1
models/tutorials.model
View File

@ -27,6 +27,7 @@ Tutor
TutorialParticipant
tutorial TutorialId OnDeleteCascade OnUpdateCascade
user UserId
company CompanyId Maybe
UniqueTutorialParticipant tutorial user
deriving Eq Ord Show
deriving Generic

6
src/Database/Esqueleto/Utils.hs
View File

@ -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)

26
src/Foundation/Authorization.hs
View File

@ -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

2
src/Foundation/Navigation.hs
View File

@ -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

2
src/Handler/Course/ParticipantInvite.hs
View File

@ -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

10
src/Handler/Course/Users.hs
View File

@ -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

6
src/Handler/Exam/Form.hs
View File

@ -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

30
src/Handler/School/DayTasks.hs
View File

@ -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

4
src/Handler/Sheet/Download.hs
View File

@ -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

2
src/Handler/Sheet/Show.hs
View File

@ -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)

9
src/Handler/Tutorial/Register.hs
View File

@ -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

4
src/Handler/Utils/AuthorshipStatement.hs
View File

@ -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

15
src/Handler/Utils/Company.hs
View File

@ -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)

18
src/Handler/Utils/Files.hs
View File

@ -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)

6
src/Handler/Utils/Term.hs
View File

@ -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

9
src/Handler/Utils/Users.hs
View File

@ -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 ]

1
src/Utils/Lens.hs
View File

@ -281,6 +281,7 @@ makeLenses_ ''CourseUserExamOfficeOptOut
makeLenses_ ''CourseNewsFile
makeLenses_ ''Tutorial
makeLenses_ ''TutorialParticipant
makeLenses_ ''SessionFile

22
test/Database/Fill.hs
View File

@ -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