diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs
index 45b47f9da..5aafa0ed9 100644
--- a/src/Handler/Firm.hs
+++ b/src/Handler/Firm.hs
@@ -7,7 +7,7 @@
{-# LANGUAGE TypeApplications #-}
module Handler.Firm
- ( getFirmAllR , postFirmAllR
+ ( getFirmAllR , postFirmAllR
, getFirmR , postFirmR
, getFirmUsersR , postFirmUsersR
, getFirmSupersR, postFirmSupersR
@@ -43,14 +43,14 @@ getFirmR, postFirmR :: CompanyShorthand -> Handler Html
getFirmR = postFirmR
postFirmR fsh = do
let fshId = CompanyKey fsh
- cusers <- runDB $ do
+ cusers <- runDB $ do
cusers <- selectList [UserCompanyCompany ==. fshId] []
selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
- csuper <- runDB $ do
+ csuper <- runDB $ do
csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] []
selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
- cactSuper <- runDB $ E.select $ do
- (usr :& spr :& scmpy) <- E.from $
+ 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)
@@ -61,28 +61,28 @@ postFirmR fsh = do
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
+
+ siteLayoutMsg (SomeMessage fsh) $ do
setTitle $ citext2Html fsh
- [whamlet|
+ [whamlet|
#{length csuper} Company Default Supervisors (non-foreign only)
-
+
$forall u <- csuper
- ^{linkUserWidget ForProfileDataR u}
#{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}
+
- #{nr} Employees supervised by ^{nameWidget dn sn}
$maybe csh <- mbCsh
$if csh /= fshId
from foreign company #{unCompanyKey csh}
- $else
- from this company
+ $else
+ from this company
$nothing
having no associated company
-
#{length cusers} Employees
+ #{length cusers} Employees
$forall u <- cusers
- ^{linkUserWidget ForProfileDataR u}
@@ -102,17 +102,17 @@ data FirmAllAction = FirmAllActNotify
nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmAllAction id
-data FirmAllActionData = FirmAllActNotifyData
+data FirmAllActionData = FirmAllActNotifyData
| FirmAllActResetSupervisionData
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company)
-resultAllCompanyEntity = _dbrOutput . _1
+resultAllCompanyEntity = _dbrOutput . _1
resultAllCompany :: Lens' AllCompanyTableData Company
-resultAllCompany = resultAllCompanyEntity . _entityVal
+resultAllCompany = resultAllCompanyEntity . _entityVal
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
resultAllCompanyUsers = _dbrOutput . _2 . _unValue
@@ -133,7 +133,7 @@ resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64
resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
-fromUserCompany mbFltr cmpy = do
+fromUserCompany mbFltr cmpy = do
usrCmpy <- E.from $ E.table @UserCompany
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
@@ -142,9 +142,9 @@ firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
+firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
--- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
+-- 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)
@@ -156,48 +156,48 @@ firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
-- [E.subSelect $ do
--- usrSuper <- E.from $ E.table @UserSupervisor
+-- 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)
+-- 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.subSelectCountDistinct $ do
- usrSuper <- E.from $ E.table @UserSupervisor
+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
firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes 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.&&. usrSuper E.^. UserSupervisorRerouteNotifications
pure $ usrSuper E.^. UserSupervisorSupervisor
firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes' cmpy = E.subSelectCount $ 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.&&. usrSuper E.^. UserSupervisorRerouteNotifications
-mkFirmAllTable ::
+mkFirmAllTable ::
-- ( Functor h, ToSortable h
- -- , AsCornice h p FirmAllActionData
- -- (DBCell (MForm Handler)
+ -- , AsCornice h p FirmAllActionData
+ -- (DBCell (MForm Handler)
-- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
-- ) cols
- -- ) =>
+ -- ) =>
Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget)
-mkFirmAllTable isAdmin uid = do
+mkFirmAllTable isAdmin uid = do
-- now <- liftIO getCurrentTime
- let
+ let
resultDBTable = DBTable{..}
- where
- dbtSQLQuery cmpy = do
+ where
+ dbtSQLQuery cmpy = do
unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
@@ -212,17 +212,50 @@ mkFirmAllTable isAdmin uid = do
)
dbtRowKey = (E.^. CompanyId)
dbtProj = dbtProjId
- dbtColonnade = -- formColonnade $
+ dbtColonnade = formColonnade $
mconcat
[ -- if not isAdmin then mempty else -- guardOnM idAdmin $
- -- hole :: (x -> f x) -> r -> f r
+ {- hole :: (x -> f x) -> r -> f r
+ (FormResult
+ (DBFormResult (Key Company) Bool (DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64))
+ )
+ -> f (FormResult
+ (DBFormResult
+ (Key Company)
+ Bool
+ (DBRow
+ (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64,
+ E.Value Word64, E.Value Word64, E.Value Word64)))))
+ -> FormResult
+ (First FirmAllActionData,
+ DBFormResult CompanyId Bool FirmAllActionData)
+ -> f (FormResult
+ (First FirmAllActionData,
+ DBFormResult CompanyId Bool FirmAllActionData))
+
+ -------
+
+ ( (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData))
+ -> f (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData))
+ )
+ -> (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
+ -> f (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
+
+ ------
+ Lens' (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData))
+ (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
+ ------
+ Lens' (FormResult (Map (Key Company) (AllCompanyTableData,Bool -> Bool)))
+ (FormResult (First FirmAllActionData, (Map (CompanyId) (FirmAllActionData ,Bool -> Bool))))
+ -- applying bringt uns unter das FormResult
+ -}
dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
- , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
+ , 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
+ , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
+ let fsh = companyShorthand firm
in anchorCell (FirmR fsh) $ toWgt fsh
- , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
+ , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr
@@ -230,7 +263,7 @@ mkFirmAllTable isAdmin uid = do
, sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
- ]
+ ]
dbtSorting = mconcat
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
@@ -243,14 +276,14 @@ mkFirmAllTable isAdmin uid = do
, singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
]
dbtFilter = mconcat
- [
+ [
]
dbtFilterUI = mconcat
- [
+ [
]
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
acts :: Map FirmAllAction (AForm Handler FirmAllActionData)
- acts = mconcat
+ acts = mconcat
[ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData
, singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData
]
@@ -268,18 +301,18 @@ mkFirmAllTable isAdmin uid = do
, dbParamsFormIdent = def
}
dbtIdent :: Text
- dbtIdent = "firm"
+ dbtIdent = "firm"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
- postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)
+ postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData)
-> FormResult ( FirmAllActionData, Set CompanyId)
postprocess inp = do
(First (Just act), cmpMap) <- inp
let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap
return (act, cmpSet)
-
+
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) -- This type signature is not optional!
resultDBTableValidator = def
& defaultSorting [SortAscBy "short"]
@@ -295,10 +328,10 @@ postFirmAllR = do
formResult firmRes $ \case
(FirmAllActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO"
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
- siteLayoutMsg MsgMenuFirms $ do
+ siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
-- $(widgetFile "firm-all")
- [whamlet|!!!STUB!!!TO DO!!!
+ [whamlet|!!!STUB!!!TO DO!!!
^{firmTable}
|]
@@ -308,9 +341,9 @@ postFirmAllR = do
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
getFirmUsersR = postFirmUsersR
-postFirmUsersR fsh = do
+postFirmUsersR fsh = do
let _fshId = CompanyKey fsh
- siteLayout (citext2widget fsh) $ do
+ siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html fsh
[whamlet|!!!STUB!!!TO DO!!!|]
@@ -320,9 +353,9 @@ postFirmUsersR fsh = do
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
getFirmSupersR = postFirmSupersR
-postFirmSupersR fsh = do
+postFirmSupersR fsh = do
let _fshId = CompanyKey fsh
- siteLayout (citext2widget fsh) $ do
+ siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html fsh
[whamlet|!!!STUB!!!TO DO!!!|]
@@ -335,7 +368,7 @@ postFirmSupersR fsh = do
-- , qtcValidUntil :: Day
-- , qtcLastRefresh :: Day
-- , qtcBlockStatus :: Maybe Bool
--- , qtcBlockFrom :: Maybe UTCTime
+-- , qtcBlockFrom :: Maybe UTCTime
-- , qtcScheduleRenewal:: Bool
-- , qtcLmsStatusTxt :: Maybe Text
-- , qtcLmsStatusDay :: Maybe UTCTime
@@ -352,7 +385,7 @@ postFirmSupersR fsh = do
-- , qtcValidUntil = compDay
-- , qtcLastRefresh = compDay
-- , qtcBlockStatus = Nothing
--- , qtcBlockFrom = Nothing
+-- , qtcBlockFrom = Nothing
-- , qtcScheduleRenewal= True
-- , qtcLmsStatusTxt = Just "Success"
-- , qtcLmsStatusDay = Just compTime
@@ -390,7 +423,7 @@ postFirmSupersR fsh = do
-- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
-- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
-- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
--- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
+-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
-- ]
@@ -445,15 +478,15 @@ postFirmSupersR fsh = do
-- -- hasQualificationUserBlock = resultQualBlock
--- data QualificationTableAction
--- = QualificationActExpire
+-- data QualificationTableAction
+-- = QualificationActExpire
-- | QualificationActUnexpire
-- | QualificationActBlockSupervisor
-- | QualificationActBlock
-- | QualificationActUnblock
-- | QualificationActRenew
-- | QualificationActGrant
--- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-- instance Universe QualificationTableAction
-- instance Finite QualificationTableAction
@@ -468,15 +501,15 @@ postFirmSupersR fsh = do
-- isAdminAct _ = True
-- -}
--- data QualificationTableActionData
--- = QualificationActExpireData
--- | QualificationActUnexpireData
+-- data QualificationTableActionData
+-- = QualificationActExpireData
+-- | QualificationActUnexpireData
-- | QualificationActBlockSupervisorData
-- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
-- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
-- | QualificationActRenewData
--- | QualificationActGrantData { qualTableActGrantUntil :: Day }
--- deriving (Eq, Ord, Show, Generic)
+-- | QualificationActGrantData { qualTableActGrantUntil :: Day }
+-- deriving (Eq, Ord, Show, Generic)
-- isExpiryAct :: QualificationTableActionData -> Bool
-- isExpiryAct QualificationActExpireData = True
@@ -514,14 +547,14 @@ postFirmSupersR fsh = do
-- )
-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
--- --
+-- --
-- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
-- E.&&. qualBlock `isLatestBlockBefore` E.val now
-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
--- E.where_ $ fltr qualUser
--- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
+-- E.where_ $ fltr qualUser
+-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-- return (qualUser, user, lmsUser, qualBlock)
@@ -531,15 +564,15 @@ postFirmSupersR fsh = do
-- )
-- => Bool
-- -> Entity Qualification
--- -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
+-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-- -> (Map CompanyId Company -> cols)
-- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
-- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
-- svs <- getSupervisees
--- now <- liftIO getCurrentTime
--- -- lookup all companies
--- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
+-- now <- liftIO getCurrentTime
+-- -- lookup all companies
+-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
-- cmps <- selectList [] [] -- [Asc CompanyShorthand]
-- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
-- let
@@ -584,14 +617,14 @@ postFirmSupersR fsh = do
-- dbtFilter = mconcat
-- [ single $ fltrUserNameEmail queryUser
-- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
--- E.from $ \usrAvs -> -- do
+-- E.from $ \usrAvs -> -- do
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
-- Nothing -> E.false
-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
--- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
+-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
-- )
@@ -600,14 +633,14 @@ postFirmSupersR fsh = do
-- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
-- )
-- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
--- E.from $ \(usrComp `E.InnerJoin` comp) -> do
+-- E.from $ \(usrComp `E.InnerJoin` comp) -> do
-- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
-- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
-- testcrit = maybe testname testnumber $ readMay $ CI.original criterion
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
--- )
+-- )
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
-- if | Just renewal <- mbRenewal
@@ -626,7 +659,7 @@ postFirmSupersR fsh = do
-- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
-- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
-- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
--- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
+-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
-- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
-- , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@@ -651,31 +684,31 @@ postFirmSupersR fsh = do
-- <*> (view resultCompanyUser >>= getCompanies)
-- <*> (view resultCompanyUser >>= getCompanyNos)
-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
--- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
+-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
--- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
+-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
-- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
-- <*> getStatusPlusTxt
-- <*> getStatusPlusDay
--- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
+-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
-- [] -> pure Nothing
-- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
--- getStatusPlusTxt =
--- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
+-- getStatusPlusTxt =
+-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
-- Just LmsBlocked{} -> return $ Just "Failed"
-- Just LmsExpired{} -> return $ Just "Expired"
-- Just LmsSuccess{} -> return $ Just "Success"
-- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
-- preview (resultLmsUser . _entityVal . _lmsUserStarted)
--- getStatusPlusDay =
--- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
+-- getStatusPlusDay =
+-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
-- lsd@(Just _) -> return lsd
-- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
-
+
-- dbtCsvDecode = Nothing
--- dbtExtraReps = []
+-- dbtExtraReps = []
-- dbtParams = DBParamsForm
-- { dbParamsFormMethod = POST
-- , dbParamsFormAction = Nothing
@@ -704,7 +737,7 @@ postFirmSupersR fsh = do
-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
-- getQualificationR = postQualificationR
--- postQualificationR sid qsh = do
+-- postQualificationR sid qsh = do
-- isAdmin <- hasReadAccessTo AdminR
-- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
-- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
@@ -719,13 +752,13 @@ postFirmSupersR fsh = do
-- }} <- getBy404 $ SchoolQualificationShort sid qsh
-- -- Block copied to Handler/Qualifications TODO: refactor
--- let getBlockReasons unblk = E.select $ do
--- (quser :& qblock) <- E.from $ E.table @QualificationUser
+-- 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)
+-- E.groupBy (qblock E.^. QualificationUserBlockReason)
-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
-- E.orderBy [E.desc countRows']
-- E.limit 7
@@ -739,34 +772,34 @@ postFirmSupersR fsh = do
-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
-- acts = mconcat $
-- [ singletonMap QualificationActExpire $ pure QualificationActExpireData
--- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
--- <$ aformMessage msgUnexpire
--- ] ++ bool
+-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
+-- <$ aformMessage msgUnexpire
+-- ] ++ bool
-- -- nonAdmin actions, ie. Supervisor
--- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
+-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
-- -- Admin-only actions
-- [ singletonMap QualificationActUnblock $ QualificationActUnblockData
-- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
--- , singletonMap QualificationActBlock $ QualificationActBlockData
+-- , singletonMap QualificationActBlock $ QualificationActBlockData
-- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
-- , singletonMap QualificationActRenew $ pure QualificationActRenewData
--- , singletonMap QualificationActGrant $ QualificationActGrantData
+-- , singletonMap QualificationActGrant $ QualificationActGrantData
-- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
-- <* aformMessage msgGrantWarning
-- ] isAdmin
-- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
--- linkUserName = bool ForProfileR ForProfileDataR isAdmin
+-- linkUserName = bool ForProfileR ForProfileDataR isAdmin
-- colChoices cmpMap = mconcat
-- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-- , colUserNameModalHdr MsgLmsUser linkUserName
--- , colUserEmail
+-- , colUserEmail
-- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
-- let icnSuper = text2markup " " <> icon IconSupervisor
--- cs = [ (cmpName, cmpSpr)
--- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
+-- cs = [ (cmpName, cmpSpr)
+-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
-- ]
-- companies = intercalate (text2markup ", ") $
@@ -775,9 +808,9 @@ postFirmSupersR fsh = do
-- , guardMonoid isAdmin colUserMatriclenr
-- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
-- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
--- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
+-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
--- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
+-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
-- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
@@ -788,13 +821,13 @@ postFirmSupersR fsh = do
-- psValidator = def & defaultSorting [SortDescBy "last-refresh"]
-- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
-- return (tbl, qent)
-
+
-- formResult lmsRes $ \case
-- (QualificationActRenewData, selectedUsers) | isAdmin -> do
--- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
+-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
-- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
-- reloadKeepGetParams $ QualificationR sid qsh
--- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
+-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
-- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
-- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
-- reloadKeepGetParams $ QualificationR sid qsh
@@ -807,18 +840,18 @@ postFirmSupersR fsh = do
-- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
-- addMessageI msgKind msgVal
-- reloadKeepGetParams $ QualificationR sid qsh
--- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
+-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
-- let selUserIds = Set.toList selectedUsers
--- (unblock, reason) = case action of
--- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
+-- (unblock, reason) = case action of
+-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
-- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
-- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
-- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
--- notify = case action of
+-- notify = case action of
-- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
-- _ -> False
-
--- oks <- runDB $ do
+
+-- oks <- runDB $ do
-- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
-- qualificationUserBlocking qid selUserIds unblock Nothing reason notify
-- let nrq = length selectedUsers
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index a2a5fc381..2e44c6323 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -1,10 +1,20 @@
--- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros
+-- SPDX-FileCopyrightText: 2022-23 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+{- FOP - Frequently occurring problems using dbTable:
+
+ - When changing a dbTable to a form, eg. using `dbSelect` then change the colonnade defnition from `dbColonnade` to `formColonnade`!
+ Both functions are equal to id, but the types are quite different.
+
+ - Don't mix up the row type alias traditionally ending with ...Data and the Action-Result-Type also ending with ...Data
+
+-}
+
module Handler.Utils.Table.Pagination
( module Handler.Utils.Table.Pagination.Types
, dbFilterKey
@@ -1654,10 +1664,12 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id
+-- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures
formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id
+-- | force the column list type for simple tables that do not contain forms, and especially no dbSelect, avoids explicit type signatures
dbColonnade :: Colonnade h r (DBCell DB x)
-> Colonnade h r (DBCell DB x)
dbColonnade = id