From f1ec4d0b7b4b83d16be6ba94ae8766eff753d9ea Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 08:59:37 +0000 Subject: [PATCH] refactor(qualifications): towards using dbtProj for companies working --- src/Handler/Qualification.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e3d83f076..9150ab903 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -153,7 +153,7 @@ mkQualificationAllTable = do data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail - , qtcCompany :: [Text] + , qtcCompany :: Maybe Text , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day @@ -168,7 +168,7 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = ["Example Brothers LLC"] + , qtcCompany = Just "Example Brothers LLC, SecondayJobs Inc" , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing @@ -281,7 +281,7 @@ isBlockAct _ = False qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Maybe (Entity LmsUser)) ) qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser @@ -345,7 +345,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -394,7 +394,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> pure ["TODO: companies not yet exported"] + <*> pure (Just "TODO: companies not yet exported") <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) @@ -444,7 +444,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR postQualificationR sid qsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- hasReadAccessTo AdminR ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) @@ -461,7 +461,7 @@ postQualificationR sid qsh = do linkUserName = bool ForProfileR ForProfileDataR isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin colChoices cmpMap = mconcat - [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + [ 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" @@ -470,21 +470,20 @@ postQualificationR sid qsh = do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ + let companies = intercalate (text2markup ", ") $ (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies - , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> do + pure $ toWgt companies + , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpEnt = Map.lookup cmpId cmpMap - , isJust cmpEnt - , let Just (Entity _ Company{companyName = cmpName}) = cmpEnt + , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt] ] - companies = intersperse (text2markup ", ") $ + companies = intercalate (text2markup ", ") $ (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - pure $ toWgt $ mconcat companies + in wgtCell companies , guardMonoid isAdmin colUserMatriclenr , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d