diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs
index 70cdaaecc..af0fd0e76 100644
--- a/src/Database/Esqueleto/Utils.hs
+++ b/src/Database/Esqueleto/Utils.hs
@@ -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
diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs
index de717655f..d711045a7 100644
--- a/src/Handler/Firm.hs
+++ b/src/Handler/Firm.hs
@@ -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
-
-
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|
+ #{length csuper} Company Default Supervisors (non-foreign only)
$forall u <- csuper
- - ^{userWidget u}
+
- ^{linkUserWidget ForProfileDataR u}
-
Employees
+ #{length cactSuper} Active Supervisors for Employees
+
+ $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper
+ - #{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
+
+
#{length cusers} Employees
$forall u <- cusers
- - ^{userWidget u}
+
- ^{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
diff --git a/src/Utils.hs b/src/Utils.hs
index 28b7d88a8..e91f92015 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -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 = ""
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index ce98b437f..8bda1668b 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -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