fix(firm): foreign supervisor counts correct and sortable

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

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  
+  ( getFirmAllR   , postFirmAllR  
-  , getFirmR, postFirmR
+  , 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 
+  cactSuper <- runDB $ E.select $ do 
-    setTitleI MsgMenuFirms
+      (usr :& spr :& scmpy) <- E.from $ 
-    [whamlet|STUB HANDLER FOR #{fsh} TO DO
+                        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')
   
-      <h3>Supervisors (non-foreign only)
+  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, postFirmAllR :: Handler Html
-getFirmAllR = do
+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
+firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do 
-  usrSuper <- E.from $ E.table @UserSupervisor
+    usrSuper <- E.from $ E.table @UserSupervisor    
-  E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
+    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)    
+      E.&&.  E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
-  return $ usrSuper E.^. UserSupervisorSupervisor
+    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)
+          return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy)
-        dbtRowKey = (E.^. CompanyShorthand)
+        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

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 = "<Space>"

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