From fcc2c1b3ab5ca914841fd93bbb8bedeeaa14ee11 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 11:15:26 +0000 Subject: [PATCH] refactor(qualifications): towards using dbtProj for companies working (2) --- .../utils/table_column/de-de-formal.msg | 2 ++ messages/uniworx/utils/table_column/en-eu.msg | 2 ++ src/Handler/Admin/Avs.hs | 2 +- src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 19 ++++++++++++++----- src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 4 ++-- 7 files changed, 23 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f0ce25d50..c3247ecf5 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanies: Firmen +TableCompanyNos: Firmennummern TableSupervisor: Ansprechpartner diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 6eeed21d1..5ff701e6a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanies: Companies +TableCompanyNos: Company numbers TableSupervisor: Supervisor diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 7d101e786..88b490be6 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -538,7 +538,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , colUserNameLink AdminUserR , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a -- , colUserCompany - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c88cfb9ba..58c87494f 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -517,7 +517,7 @@ postLmsR sid qsh = do [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9150ab903..9dc345872 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -154,6 +154,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail , qtcCompany :: Maybe Text + , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day @@ -168,7 +169,8 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = Just "Example Brothers LLC, SecondayJobs Inc" + , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" + , qtcCompanyNumbers = CsvSemicolonList [27,69] , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing @@ -201,7 +203,8 @@ instance CsvColumnsExplained QualificationTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList [ ('qtcDisplayName , SomeMessage MsgLmsUser) , ('qtcEmail , SomeMessage MsgTableLmsEmail) - , ('qtcCompany , SomeMessage MsgTableCompany) + , ('qtcCompany , SomeMessage MsgTableCompanies) + , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) @@ -394,13 +397,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> pure (Just "TODO: companies not yet exported") + <*> (view resultCompanyUser >>= getCompanies) + <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + [] -> pure Nothing + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_entityVal . _companyName . _CI)) somecmps + getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + getStatusPlusTxt = (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case Just LmsBlocked{} -> return $ Just "Failed" @@ -464,7 +473,7 @@ postQualificationR sid qsh = do [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -474,7 +483,7 @@ postQualificationR sid qsh = do (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt companies - , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> + , sortable (Just "company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 67e3ac395..0bc4e434a 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -100,7 +100,7 @@ postUsersR = do (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 473b3c484..07a122af2 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -718,7 +718,7 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI {- -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> do +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do let uid = heu ^. hasEntity . _entityKey companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -732,7 +732,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \he -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> let uid = heu ^. hasEntity . _entityKey in sqlCell $ do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do