From 92e83475a94b6b0a1ea0ecd2f03b493422459ba2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 15:45:59 +0000 Subject: [PATCH] chore(firm): link firms throughout --- routes | 8 ++++---- src/Handler/Admin/Avs.hs | 11 +++++----- src/Handler/Firm.hs | 35 +++++++++++++++----------------- src/Handler/LMS.hs | 13 +++++------- src/Handler/Qualification.hs | 11 ++++------ src/Handler/Users.hs | 10 ++++----- src/Handler/Utils/Table/Cells.hs | 10 +++++++++ src/Utils.hs | 4 ++++ 8 files changed, 54 insertions(+), 48 deletions(-) diff --git a/routes b/routes index 0af78745f..b4485c890 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET +/firm FirmAllR GET /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: @@ -278,7 +278,7 @@ /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -- old V1 LMS Interface /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor @@ -287,11 +287,11 @@ /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET -/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST /lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS --- other lms routes +-- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET /lmsuser/#CryptoUUIDUser LmsUserAllR GET diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index e7b4fda22..365143304 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -556,11 +556,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId 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 ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + + pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e7a56a29..fe487f78c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,7 +28,7 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto.Utils.TH +import Database.Esqueleto.Utils.TH -- avoids repetition of local definitions @@ -38,10 +38,10 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR -postFirmR _ = do +postFirmR fsh = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms - [whamlet|STUB TO DO|] + [whamlet|STUB FOR #{fsh} TO DO|] getFirmAllR :: Handler Html @@ -53,8 +53,7 @@ getFirmAllR = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - + [whamlet|!!!STUB!!!TO DO!!! ^{firmTable} |] @@ -73,9 +72,9 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue -mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget) -mkQualificationAllTable isAdmin uid = do - now <- liftIO getCurrentTime +mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) +mkFirmAllTable isAdmin uid = do + -- now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where @@ -83,7 +82,7 @@ mkQualificationAllTable isAdmin uid = do let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId cforeign = E.subSelectCount $ E.distinct $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ (E.exists $ do + E.where_ $ E.exists (do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser ) E.&&. E.notExists (do @@ -97,23 +96,21 @@ mkQualificationAllTable isAdmin uid = do csupers = E.subSelectCount $ do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor - whenIsJust mbUid $ \uid -> - E.where_ $ E.exists $ do -- only show associated companies - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return (cmpy, csupers, cusers, cforeign) dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) + sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm - anchorCell (FirmR fsh) $ toWgt fsh + let fsh = companyShorthand firm + in anchorCell (FirmR fsh) $ toWgt fsh , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm - anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm + anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index cdd720509..c927cc8f8 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -42,7 +42,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as T -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma @@ -445,7 +445,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let - csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) + csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery now qid @@ -506,7 +506,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId - testcrit = maybe testname testnumber $ readMay $ CI.original criterion + testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) @@ -637,14 +637,11 @@ postLmsR sid qsh = do , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6553bb300..5297c8801 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -586,14 +586,11 @@ postQualificationR sid qsh = do , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) - | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , guardMonoid isAdmin colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 23ca1e78d..f5ae958e4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -106,11 +106,11 @@ postUsersR = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId 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 ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + pure $ intercalate (text2widget "; ") companies , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (toWgt userCompanyPersonalNumber) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 42970a046..e19be03aa 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -307,6 +307,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc ^{modal "Beschreibung" (Right $ toWidget descr)} |] +companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a +companyCell cid cname isSupervisor = anchorCell link name + where + link = FirmR cid + corg = ciOriginal cname + name + | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor + | otherwise = text2markup corg + + qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name where diff --git a/src/Utils.hs b/src/Utils.hs index 7ff482a96..28b7d88a8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -305,6 +305,10 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | just to avoid adding an import for this +ciOriginal :: CI Text -> Text +ciOriginal = CI.original + citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original