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)