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

fix(firm): foreign supervisor counts correct and sortable

Browse Source
This commit is contained in:
Steffen Jost 2023-10-20 15:29:40 +00:00
parent 4cdf39a1fd
commit 601ce7abdf
4 changed files with 106 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Database/Esqueleto/Utils.hs
View File

@ -43,6 +43,7 @@ module Database.Esqueleto.Utils
, (->.), (->>.), (#>>.)
, fromSqlKey
, unKey
, subSelectCountDistinct
, selectCountRows, selectCountDistinct
, selectMaybe
, day, day', dayMaybe, interval, diffDays, diffTimes
@ -628,6 +629,12 @@ unKey :: ( Coercible (Key entity) a
unKey = E.veryUnsafeCoerceSqlExprValue
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
selectCountRows q = do
res <- E.select $ E.countRows <$ q

120
src/Handler/Firm.hs
View File

@ -2,13 +2,15 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# LANGUAGE TypeApplications #-}
module Handler.Firm
( getFirmAllR
, getFirmR, postFirmR
( getFirmAllR , postFirmAllR
, getFirmR , postFirmR
, getFirmUsersR , postFirmUsersR
, getFirmSupersR, postFirmSupersR
)
where
@ -24,11 +26,11 @@ import Handler.Utils
-- import qualified Data.CaseInsensitive as CI
-- import qualified Data.Conduit.List as C
-- import Database.Persist.Sql (updateWhereCount)
-- import Database.Esqueleto.Experimental ((:&)(..))
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-- import qualified Database.Esqueleto.Legacy as E
-- import qualified Database.Esqueleto.Legacy as EL
-- import qualified Database.Esqueleto.PostgreSQL as E
-- import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
@ -40,32 +42,58 @@ import Database.Esqueleto.Utils.TH
getFirmR, postFirmR :: CompanyShorthand -> Handler Html
getFirmR = postFirmR
postFirmR fsh = do
let fshId = CompanyKey fsh
cusers <- runDB $ do
cusers <- selectList [UserCompanyCompany ==. CompanyKey fsh] []
cusers <- selectList [UserCompanyCompany ==. fshId] []
selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
csuper <- runDB $ do
csuper <- selectList [UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] []
csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] []
selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
[whamlet|STUB HANDLER FOR #{fsh} TO DO
<h3>Supervisors (non-foreign only)
cactSuper <- runDB $ E.select $ do
(usr :& spr :& scmpy) <- E.from $
E.table @User
`E.innerJoin` E.table @UserSupervisor
`E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
`E.leftJoin` E.table @UserCompany
`E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser)
E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers)
E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany)
E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany]
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows')
siteLayoutMsg (SomeMessage fsh) $ do
setTitle $ citext2Html fsh
[whamlet|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
<ul>
$forall u <- csuper
<li>^{userWidget u}
<li>^{linkUserWidget ForProfileDataR u}
<h3>Employees
<h3>#{length cactSuper} Active Supervisors for Employees
<ul>
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper
<li>#{nr} Employees supervised by ^{nameWidget dn sn}
$maybe csh <- mbCsh
$if csh /= fshId
from foreign company #{unCompanyKey csh}
$else
from this company
$nothing
having no associated company
<h3>#{length cusers} Employees
<ul>
$forall u <- cusers
<li>^{userWidget u}
<li>^{linkUserWidget ForProfileDataR u}
In the end, this needs to be a dbTable, of course!
|]
getFirmAllR :: Handler Html
getFirmAllR = do
getFirmAllR, postFirmAllR :: Handler Html
getFirmAllR = postFirmAllR
postFirmAllR = do
uid <- requireAuthId
isAdmin <- hasReadAccessTo AdminR
firmTable <- runDB $ do
@ -82,11 +110,11 @@ type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64
resultAllCompany :: Lens' AllCompanyTableData Company
resultAllCompany = _dbrOutput . _1 . _entityVal
resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
resultAllCompanySupervisors = _dbrOutput . _2 . _unValue
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
resultAllCompanyUsers = _dbrOutput . _3 . _unValue
resultAllCompanyUsers = _dbrOutput . _2 . _unValue
resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue
@ -102,13 +130,30 @@ firmCountUsers = E.subSelectCount . fromUserCompany Nothing
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
-- usrCmpy <- E.from $ E.table @UserCompany
-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId)
-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
-- return $ usrCmpy E.^. UserCompanyUser
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
-- [E.subSelect $ do
-- usrSuper <- E.from $ E.table @UserSupervisor
-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
-- return E.countRows
-- ] (E.val 0)
firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountForeignSupervisors cmpy = E.subSelectCount $ E.distinct $ do
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
return $ usrSuper E.^. UserSupervisorSupervisor
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
pure $ usrSuper E.^. UserSupervisorSupervisor
mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
mkFirmAllTable isAdmin uid = do
@ -121,8 +166,8 @@ mkFirmAllTable isAdmin uid = do
usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
return (cmpy, firmCountForeignSupervisors cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy)
dbtRowKey = (E.^. CompanyShorthand)
return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy)
dbtRowKey = (E.^. CompanyId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand))
@ -169,6 +214,23 @@ mkFirmAllTable isAdmin uid = do
-- -- getQualificationEditR = postQualificationEditR
-- -- postQualificationEditR = error "TODO"
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
getFirmUsersR = postFirmUsersR
postFirmUsersR fsh = do
let _fshId = CompanyKey fsh
siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html fsh
[whamlet|!!!STUB!!!TO DO!!!|]
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
getFirmSupersR = postFirmSupersR
postFirmSupersR fsh = do
let _fshId = CompanyKey fsh
siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html fsh
[whamlet|!!!STUB!!!TO DO!!!|]
-- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
-- { qtcDisplayName :: UserDisplayName
-- , qtcEmail :: UserEmail

3
src/Utils.hs
View File

@ -364,6 +364,9 @@ text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
text2Html :: Text -> Html
text2Html = toHtml
citext2Html :: CI Text -> Html
citext2Html = toHtml . CI.original
char2Text :: Char -> Text
char2Text c
| isSpace c = "<Space>"

7
test/Database/Fill.hs
View File

@ -569,7 +569,7 @@ fillDb = do
userDisplayEmail' = CI.mk $ case userSurname of
"Walker" -> "AVSNO:" <> userMatrikelnummer'
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
"Elizabeth" -> ""
"Jackson" -> ""
_ -> userIdent
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
@ -636,7 +636,10 @@ fillDb = do
void . insert' $ UserCompany fhamann bpol False False
void . insert' $ UserCompany fhamann ffacil True True
void . insert' $ UserCompany fhamann nice False False
insertMany_ [UserCompany uid fraGround False False| Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userDisplayName = dn} <- matUsers, dn == "Walker" || dn == "John"]
insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
-- void . insert' $ UserSupervisor jost gkleen True
-- void . insert' $ UserSupervisor jost svaupel False
-- void . insert' $ UserSupervisor jost sbarth False