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