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

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}

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}

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

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

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

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)
+-- DEPRECATED: use Database.Esqueleto.selectOne instead
-selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
+-- 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)

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    
+    r -> $unsupportedAuthPredicate AuthSupervisor r
-  where 
+  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
 

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

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

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 $
+        Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do
-          void . insertUnique . TutorialParticipant registerTutorial
+          fsh <- selectCompanyUserPrime' uid
-        addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
+          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

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

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))
+      , ("course"         , SortColumn $ queryCourse      >>> (E.^. CourseName))
-      , ("tutorial"    , SortColumn $ queryTutorial >>> (E.^. TutorialName))
+      , ("tutorial"       , SortColumn $ queryTutorial    >>> (E.^. TutorialName))
-      , ("user-company", SortColumn $ queryUser     >>> selectCompanyUserPrime)
+      , ("user-company"   , SortColumn $ queryUser        >>> selectCompanyUserPrime)
+      , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
       ]
     dbtFilter = Map.fromList
       [ fltrUserNameEmail   queryUser

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

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)

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
+      ok <- runDB $ do
-      addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
+        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

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

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)

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)

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

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 ]

src/Utils/Lens.hs

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

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 tut1 svaupel Nothing
-        insert_ $ TutorialParticipant tut2 svaupel
+        insert_ $ TutorialParticipant tut2 svaupel $ Just fraGround
-        when (odd  tyear) $ insert_ $ TutorialParticipant tut3 svaupel
+        when (odd  tyear) $ insert_ $ TutorialParticipant tut3 svaupel $ Just fraGround
-        insert_ $ TutorialParticipant tut1 gkleen
+        insert_ $ TutorialParticipant tut1 gkleen   $ Just nice
-        insert_ $ TutorialParticipant tut2 fhamann
+        insert_ $ TutorialParticipant tut2 fhamann $ Just bpol
-        when (even tyear) $ insert_ $ TutorialParticipant tut3 jost
+        when (even tyear) $ insert_ $ TutorialParticipant tut3 jost $ Just fraportAg
         when (odd tyear) $
           void . insert' $ Exam
             { examCourse = c