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

refactor(qualifications): towards using dbtProj for companies working (2)

Browse Source
This commit is contained in:
Steffen Jost 2023-04-28 11:15:26 +00:00
parent f1ec4d0b7b
commit fcc2c1b3ab
7 changed files with 23 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen TableQualifications: Qualifikationen
TableCompany: Firma TableCompany: Firma
TableCompanies: Firmen
TableCompanyNos: Firmennummern
TableSupervisor: Ansprechpartner TableSupervisor: Ansprechpartner

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

@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications TableQualifications: Qualifications
TableCompany: Company TableCompany: Company
TableCompanies: Companies
TableCompanyNos: Company numbers
TableSupervisor: Supervisor TableSupervisor: Supervisor

2
src/Handler/Admin/Avs.hs
View File

@ -538,7 +538,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, colUserNameLink AdminUserR , colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany -- , 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 companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid

2
src/Handler/LMS.hs
View File

@ -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" [ 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 , colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail , 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 companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid

19
src/Handler/Qualification.hs
View File

@ -154,6 +154,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName { qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail , qtcEmail :: UserEmail
, qtcCompany :: Maybe Text , qtcCompany :: Maybe Text
, qtcCompanyNumbers :: CsvSemicolonList Int
, qtcValidUntil :: Day , qtcValidUntil :: Day
, qtcLastRefresh :: Day , qtcLastRefresh :: Day
, qtcBlocked :: Maybe Day , qtcBlocked :: Maybe Day
@ -168,7 +169,8 @@ qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann" { qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com" , 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 , qtcValidUntil = compDay
, qtcLastRefresh = compDay , qtcLastRefresh = compDay
, qtcBlocked = Nothing , qtcBlocked = Nothing
@ -201,7 +203,8 @@ instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('qtcDisplayName , SomeMessage MsgLmsUser) [ ('qtcDisplayName , SomeMessage MsgLmsUser)
, ('qtcEmail , SomeMessage MsgTableLmsEmail) , ('qtcEmail , SomeMessage MsgTableLmsEmail)
, ('qtcCompany , SomeMessage MsgTableCompany) , ('qtcCompany , SomeMessage MsgTableCompanies)
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
@ -394,13 +397,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = QualificationTableCsv doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultUser . _entityVal . _userDisplayEmail)
<*> pure (Just "TODO: companies not yet exported") <*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt <*> getStatusPlusTxt
<*> getStatusPlusDay <*> 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 = getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
Just LmsBlocked{} -> return $ Just "Failed" Just LmsBlocked{} -> return $ Just "Failed"
@ -464,7 +473,7 @@ postQualificationR sid qsh = do
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName , colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail , 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 companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid 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' (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt companies pure $ toWgt companies
, sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> , sortable (Just "company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let icnSuper = text2markup " " <> icon IconSupervisor let icnSuper = text2markup " " <> icon IconSupervisor
cs = [ (cmpName, cmpSpr) cs = [ (cmpName, cmpSpr)
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps

2
src/Handler/Users.hs
View File

@ -100,7 +100,7 @@ postUsersR = do
(AdminUserR <$> encrypt uid) (AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname) (nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr , 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 companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid

4
src/Handler/Utils/Table/Columns.hs
View File

@ -718,7 +718,7 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
{- {-
-- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -- 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 let uid = heu ^. hasEntity . _entityKey
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid 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? -- 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 :: (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 let uid = heu ^. hasEntity . _entityKey in
sqlCell $ do sqlCell $ do
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do