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

chore(firm): link firms throughout

Browse Source
This commit is contained in:
Steffen Jost 2023-10-18 15:45:59 +00:00
parent d81e6e15dc
commit 92e83475a9
8 changed files with 54 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
routes
View File

@ -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

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

@ -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

35
src/Handler/Firm.hs
View File

@ -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

13
src/Handler/LMS.hs
View File

@ -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

11
src/Handler/Qualification.hs
View File

@ -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

10
src/Handler/Users.hs
View File

@ -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)

10
src/Handler/Utils/Table/Cells.hs
View File

@ -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

4
src/Utils.hs
View File

@ -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