chore(firm): WIP company overview
This commit is contained in:
parent
db4b1d8730
commit
d81e6e15dc
@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label-Farbe
|
||||
TableExamOfficeLabelPriority: Label-Priorität
|
||||
TableQualifications: Qualifikationen
|
||||
TableCompany: Firma
|
||||
TableCompanyShort: Firmenkürzel
|
||||
TableCompanies: Firmen
|
||||
TableCompanyNo: Firmennummer
|
||||
TableCompanyNos: Firmennummern
|
||||
TableCompanyNrUsers: Firmenangehörige
|
||||
TableCompanyNrSupers: Ansprechpartner
|
||||
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
|
||||
TableSupervisor: Ansprechpartner
|
||||
TableCreationTime: Erstellungszeit
|
||||
TableJob !ident-ok: Job
|
||||
|
||||
@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label colour
|
||||
TableExamOfficeLabelPriority: Label priority
|
||||
TableQualifications: Qualifications
|
||||
TableCompany: Company
|
||||
TableCompanyShort: Company shorthand
|
||||
TableCompanies: Companies
|
||||
TableCompanyNo: Company number
|
||||
TableCompanyNos: Company numbers
|
||||
TableCompanyNrUsers: Associates
|
||||
TableCompanyNrSupers: Supervisors
|
||||
TableCompanyNrForeignSupers: External Supervisors
|
||||
TableSupervisor: Supervisor
|
||||
TableCreationTime: Creation
|
||||
TableJob !ident-ok: Job
|
||||
|
||||
2
routes
2
routes
@ -113,7 +113,7 @@
|
||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||
|
||||
/firm FirmAllR GET !free
|
||||
/firm FirmAllR GET
|
||||
/firm/#CompanyShorthand FirmR GET POST
|
||||
|
||||
/exam-office ExamOfficeR !exam-office:
|
||||
|
||||
@ -24,7 +24,7 @@ import Handler.Utils
|
||||
-- import qualified Data.Conduit.List as C
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
-- import qualified Database.Esqueleto.Legacy as E
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
-- import qualified Database.Esqueleto.Utils as E
|
||||
@ -49,7 +49,7 @@ getFirmAllR = do
|
||||
uid <- requireAuthId
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
firmTable <- runDB $ do
|
||||
view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins
|
||||
view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins
|
||||
siteLayoutMsg MsgMenuFirms $ do
|
||||
setTitleI MsgMenuFirms
|
||||
-- $(widgetFile "firm-all")
|
||||
@ -59,7 +59,7 @@ getFirmAllR = do
|
||||
|]
|
||||
|
||||
|
||||
type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64)
|
||||
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64)
|
||||
resultAllCompany :: Lens' AllCompanyTableData Company
|
||||
resultAllCompany = _dbrOutput . _1 . _entityVal
|
||||
|
||||
@ -73,95 +73,72 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
|
||||
resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue
|
||||
|
||||
|
||||
mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget)
|
||||
mkQualificationAllTable mbUid = do
|
||||
|
||||
mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget)
|
||||
mkQualificationAllTable isAdmin uid = do
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery cmpy = do
|
||||
let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId
|
||||
cforeign = Ex.subSelectCount $ Ex.distinct $ do
|
||||
usrSuper <- Ex.from $ Ex.table @UserSupervisor
|
||||
Ex.where_ (Ex.exists $ do
|
||||
usrCmpy <- Ex.from $ Ex.table @UserCompany
|
||||
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser
|
||||
) E.&&. Ex.notExists (do
|
||||
usrCmpy <- Ex.from $ Ex.table @UserCompany
|
||||
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor
|
||||
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
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser
|
||||
) E.&&. E.notExists (do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor
|
||||
)
|
||||
return $ usrSuper E.^. UserSupervisorSupervisor
|
||||
cusers = Ex.subSelectCount $ do
|
||||
usrCmpy <- Ex.from $ Ex.table @UserCompany
|
||||
Ex.where_ $ filterCmpy usrCmpy
|
||||
csupers = Ex.subSelectCount $ do
|
||||
usrCmpy <- Ex.from $ Ex.table @UserCompany
|
||||
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor
|
||||
cusers = E.subSelectCount $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ filterCmpy usrCmpy
|
||||
csupers = E.subSelectCount $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor
|
||||
whenIsJust mbUid $ \uid ->
|
||||
Ex.where_ $ Ex.exists $ do -- only show associated companies
|
||||
usrCmpy <- Ex.from $ Ex.table @UserCompany
|
||||
Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val 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
|
||||
return (cmpy, csupers, cusers, cforeign)
|
||||
dbtRowKey = (Ex.^. CompanyShorthand)
|
||||
dbtRowKey = (E.^. CompanyShorthand)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ colSchool $ resultAllQualification . _qualificationSchool
|
||||
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
|
||||
let qsh = qualificationShorthand quali in
|
||||
anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
|
||||
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
|
||||
let qsh = qualificationShorthand quali
|
||||
qnm = qualificationName quali
|
||||
in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
|
||||
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
|
||||
maybeCell (qualificationDescription quali) markupCellLargeModal
|
||||
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
|
||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
|
||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
||||
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId
|
||||
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
||||
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
||||
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
||||
[ 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
|
||||
, sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
|
||||
let fsh = companyShorthand firm
|
||||
anchorCell (FirmR fsh) $ 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
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[
|
||||
sortSchool $ to (E.^. QualificationSchool)
|
||||
, singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand)
|
||||
, singletonMap "qname" $ SortColumn (E.^. QualificationName)
|
||||
, singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart)
|
||||
, singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification)
|
||||
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
|
||||
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
|
||||
, singletonMap "nr" $ SortColumn (E.^. CompanyAvsId)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[
|
||||
fltrSchool $ to (E.^. QualificationSchool)
|
||||
, singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
|
||||
[
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[
|
||||
fltrSchoolUI
|
||||
, \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning)
|
||||
[
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "qualification-overview"
|
||||
dbtIdent = "firm"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
|
||||
resultDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "school", SortAscBy "qshort"]
|
||||
-- & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
|
||||
dbTable resultDBTableValidator resultDBTable
|
||||
|
||||
|
||||
@ -391,7 +368,7 @@ mkQualificationAllTable mbUid = do
|
||||
-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
||||
-- dbtIdent :: Text
|
||||
-- dbtIdent = "qualification"
|
||||
-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
|
||||
-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs
|
||||
-- dbtSQLQuery = qualificationTableQuery now qid fltrSvs
|
||||
-- dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
-- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
|
||||
@ -562,21 +539,21 @@ mkQualificationAllTable mbUid = do
|
||||
-- }} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
|
||||
-- -- Block copied to Handler/Qualifications TODO: refactor
|
||||
-- let getBlockReasons unblk = Ex.select $ do
|
||||
-- (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
|
||||
-- `Ex.innerJoin` Ex.table @QualificationUserBlock
|
||||
-- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
|
||||
-- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid
|
||||
-- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
|
||||
-- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
|
||||
-- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
|
||||
-- Ex.orderBy [Ex.desc countRows']
|
||||
-- Ex.limit 7
|
||||
-- pure (qblock Ex.^. QualificationUserBlockReason)
|
||||
-- mkOption :: Ex.Value Text -> Option Text
|
||||
-- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
-- let getBlockReasons unblk = E.select $ do
|
||||
-- (quser :& qblock) <- E.from $ E.table @QualificationUser
|
||||
-- `E.innerJoin` E.table @QualificationUserBlock
|
||||
-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
|
||||
-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
-- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
|
||||
-- E.groupBy (qblock E.^. QualificationUserBlockReason)
|
||||
-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||
-- E.orderBy [E.desc countRows']
|
||||
-- E.limit 7
|
||||
-- pure (qblock E.^. QualificationUserBlockReason)
|
||||
-- mkOption :: E.Value Text -> Option Text
|
||||
-- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
-- suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
||||
-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_)
|
||||
-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
|
||||
-- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
|
||||
-- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
|
||||
-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user