|
|
|
@ -2,7 +2,7 @@
|
|
|
|
--
|
|
|
|
--
|
|
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
|
|
|
|
|
|
|
|
{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only
|
|
|
|
{-# OPTIONS -Wno-unused-top-binds #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
|
|
|
|
|
|
|
|
@ -32,7 +32,7 @@ import qualified Data.CaseInsensitive as CI
|
|
|
|
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
|
|
|
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
|
|
import qualified Database.Esqueleto.Legacy as EL (from, on)
|
|
|
|
import qualified Database.Esqueleto.Legacy as EL (on)
|
|
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
@ -42,11 +42,11 @@ import Database.Esqueleto.Utils.TH
|
|
|
|
single :: (k,a) -> Map k a
|
|
|
|
single :: (k,a) -> Map k a
|
|
|
|
single = uncurry Map.singleton
|
|
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
|
|
|
|
|
|
decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
|
|
|
|
-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
|
|
|
|
decryptUser = decrypt
|
|
|
|
-- decryptUser = decrypt
|
|
|
|
|
|
|
|
|
|
|
|
encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
|
|
|
|
encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
|
|
|
|
encryptUser = encrypt
|
|
|
|
encryptUser = encrypt
|
|
|
|
|
|
|
|
|
|
|
|
postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
|
|
|
|
postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
|
|
|
|
postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged
|
|
|
|
postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged
|
|
|
|
@ -56,7 +56,9 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
|
|
|
|
|
|
|
|
|
|
|
|
data FirmAction = FirmActNotify
|
|
|
|
data FirmAction = FirmActNotify
|
|
|
|
| FirmActResetSupervision
|
|
|
|
| FirmActResetSupervision
|
|
|
|
| FirmActAddSupervisors
|
|
|
|
| FirmActAddSupersvisors
|
|
|
|
|
|
|
|
| FirmActChangeContactFirm
|
|
|
|
|
|
|
|
| FirmActChangeContactUser
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
|
|
|
|
|
|
|
|
@ -64,41 +66,54 @@ nullaryPathPiece ''FirmAction $ camelToPathPiece' 2
|
|
|
|
embedRenderMessage ''UniWorX ''FirmAction id
|
|
|
|
embedRenderMessage ''UniWorX ''FirmAction id
|
|
|
|
|
|
|
|
|
|
|
|
data FirmActionData = FirmActNotifyData
|
|
|
|
data FirmActionData = FirmActNotifyData
|
|
|
|
| FirmActResetSupervisionData
|
|
|
|
| FirmActResetSupervisionData
|
|
|
|
{ firmActResetKeepOldSupers :: Maybe Bool
|
|
|
|
{ firmActResetKeepOldSupers :: Maybe Bool
|
|
|
|
, firmActResetMutualSupervision :: Maybe Bool
|
|
|
|
, firmActResetMutualSupervision :: Maybe Bool
|
|
|
|
}
|
|
|
|
}
|
|
|
|
| FirmActAddSupervisorsData
|
|
|
|
| FirmActAddSupersvisorsData
|
|
|
|
{ firmActAddSupervisorIds :: Set Text
|
|
|
|
{ firmActAddSupervisorIds :: Set Text
|
|
|
|
, firmActAddSupervisorReroute :: Bool
|
|
|
|
, firmActAddSupervisorReroute :: Bool
|
|
|
|
, firmActAddSupervisorPostal :: Maybe Bool
|
|
|
|
, firmActAddSupervisorPostal :: Maybe Bool
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
| FirmActChangeContactFirmData
|
|
|
|
|
|
|
|
{ firmActCCFPostalAddr :: Maybe StoredMarkup
|
|
|
|
|
|
|
|
, firmActCCFEmail :: Maybe UserEmail
|
|
|
|
|
|
|
|
, firmActCCFPostalPref :: Maybe Bool
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
| FirmActChangeContactUserData
|
|
|
|
|
|
|
|
{ firmActCCUPostalAddr :: Maybe StoredMarkup
|
|
|
|
|
|
|
|
, firmActCCUPostalPref :: Maybe Bool
|
|
|
|
}
|
|
|
|
}
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
|
|
|
|
|
|
firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
|
|
|
|
firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
|
|
|
|
firmActionMap acts = mconcat (mkAct <$> acts)
|
|
|
|
firmActionMap mr acts = mconcat (mkAct <$> acts)
|
|
|
|
where
|
|
|
|
where
|
|
|
|
mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
|
|
|
|
mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
|
|
|
|
mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
|
|
|
|
mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
|
|
|
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
|
|
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
|
|
|
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
|
|
|
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
|
|
|
mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
|
|
|
|
mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData
|
|
|
|
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
|
|
|
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
|
|
|
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
|
|
|
|
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True)
|
|
|
|
<*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing
|
|
|
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
|
|
|
|
|
|
|
mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
|
|
|
|
|
|
|
|
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
|
|
|
|
|
|
|
|
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing
|
|
|
|
|
|
|
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
|
|
|
|
|
|
|
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
|
|
|
|
|
|
|
|
mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
|
|
|
|
|
|
|
|
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
|
|
|
|
|
|
|
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
|
|
|
|
|
|
|
|
|
|
|
firmActionForm :: [FirmAction] -> AForm Handler FirmActionData
|
|
|
|
firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData
|
|
|
|
firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing
|
|
|
|
firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
|
|
|
|
makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
|
|
|
|
makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts
|
|
|
|
makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ())
|
|
|
|
|
|
|
|
-- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
|
|
|
|
firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
|
|
|
|
firmActionHandler route = flip formResult faHandler
|
|
|
|
firmActionHandler route = flip formResult faHandler
|
|
|
|
where
|
|
|
|
where
|
|
|
|
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
|
|
|
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
|
|
|
faHandler (FirmActResetSupervisionData{..}, fids) = do
|
|
|
|
faHandler (FirmActResetSupervisionData{..}, fids) = do
|
|
|
|
@ -109,10 +124,10 @@ firmActionHandler route = flip formResult faHandler
|
|
|
|
E.where_ $ E.exists $ do
|
|
|
|
E.where_ $ E.exists $ do
|
|
|
|
usr <- E.from $ E.table @UserCompany
|
|
|
|
usr <- E.from $ E.table @UserCompany
|
|
|
|
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
|
|
|
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
|
|
|
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
|
|
|
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
|
|
|
else return 0
|
|
|
|
else return 0
|
|
|
|
newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids
|
|
|
|
newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids
|
|
|
|
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
|
|
|
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
|
|
|
|
reloadKeepGetParams route -- reload to reflect changes
|
|
|
|
reloadKeepGetParams route -- reload to reflect changes
|
|
|
|
|
|
|
|
|
|
|
|
faHandler (FirmActNotifyData, Set.toList -> fids) = do
|
|
|
|
faHandler (FirmActNotifyData, Set.toList -> fids) = do
|
|
|
|
@ -123,7 +138,7 @@ firmActionHandler route = flip formResult faHandler
|
|
|
|
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
|
|
|
|
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
|
|
|
|
redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
|
|
redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
|
|
|
|
|
|
|
|
|
|
faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
|
|
|
|
faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
|
|
|
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
|
|
|
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
|
|
|
|
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
|
|
|
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
|
|
|
usersFound = mapMaybe snd usersFound'
|
|
|
|
usersFound = mapMaybe snd usersFound'
|
|
|
|
@ -136,24 +151,51 @@ firmActionHandler route = flip formResult faHandler
|
|
|
|
|]
|
|
|
|
|]
|
|
|
|
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
|
|
|
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
|
|
|
when (null usersFound) $ do
|
|
|
|
when (null usersFound) $ do
|
|
|
|
addMessageI Warning MsgASReqEmpty
|
|
|
|
addMessageI Warning MsgFirmActAddSupersEmpty
|
|
|
|
reloadKeepGetParams route
|
|
|
|
reloadKeepGetParams route
|
|
|
|
runDB $ do
|
|
|
|
runDB $ do
|
|
|
|
putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
|
|
|
|
putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
|
|
|
|
whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
|
|
|
|
whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
|
|
|
|
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
|
|
|
|
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
|
|
|
|
addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal
|
|
|
|
addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
|
|
|
|
redirect route
|
|
|
|
redirect route
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) =
|
|
|
|
|
|
|
|
let changes = catMaybes
|
|
|
|
|
|
|
|
[ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr
|
|
|
|
|
|
|
|
, (CompanyEmail =.) . Just <$> canonical firmActCCFEmail
|
|
|
|
|
|
|
|
, (CompanyPrefersPostal =.) <$> firmActCCFPostalPref
|
|
|
|
|
|
|
|
]
|
|
|
|
|
|
|
|
in unless (null changes) $ do
|
|
|
|
|
|
|
|
runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes
|
|
|
|
|
|
|
|
addMessageI Success MsgFirmActChangeContactFirmResult
|
|
|
|
|
|
|
|
reloadKeepGetParams route
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
|
|
|
|
|
|
|
|
let changes = catMaybes
|
|
|
|
|
|
|
|
[ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
|
|
|
|
|
|
|
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
|
|
|
|
|
|
|
]
|
|
|
|
|
|
|
|
in unless (null changes) $ do
|
|
|
|
|
|
|
|
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
|
|
|
|
|
|
|
E.set usr changes
|
|
|
|
|
|
|
|
E.where_ $ E.exists $ do
|
|
|
|
|
|
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
|
|
|
|
|
|
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
|
|
|
|
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
|
|
|
|
|
|
|
addMessageI Success $ MsgFirmUserChanges nrChanged
|
|
|
|
|
|
|
|
reloadKeepGetParams route -- reload to reflect changes
|
|
|
|
|
|
|
|
|
|
|
|
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
|
|
|
|
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget
|
|
|
|
runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget
|
|
|
|
runFirmActionFormPost cid route acts = do
|
|
|
|
runFirmActionFormPost cid route acts = do
|
|
|
|
-- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts
|
|
|
|
mr <- getMessageRender
|
|
|
|
((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts
|
|
|
|
((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts
|
|
|
|
let faAnchor = "firm-action-form" :: Text
|
|
|
|
let faAnchor = "firm-action-form" :: Text
|
|
|
|
faRoute = route :#: faAnchor
|
|
|
|
faRoute = route :#: faAnchor
|
|
|
|
faForm = wrapForm faWgt FormSettings
|
|
|
|
faForm = wrapForm faWgt FormSettings
|
|
|
|
{ formMethod = POST
|
|
|
|
{ formMethod = POST
|
|
|
|
, formAction = Just . SomeRoute $ faRoute
|
|
|
|
, formAction = Just . SomeRoute $ faRoute
|
|
|
|
, formEncoding = faEnctype
|
|
|
|
, formEncoding = faEnctype
|
|
|
|
@ -162,14 +204,17 @@ runFirmActionFormPost cid route acts = do
|
|
|
|
, formAnchor = Just faAnchor
|
|
|
|
, formAnchor = Just faAnchor
|
|
|
|
}
|
|
|
|
}
|
|
|
|
firmActionHandler route faRes
|
|
|
|
firmActionHandler route faRes
|
|
|
|
return [whamlet|
|
|
|
|
return [whamlet|
|
|
|
|
<section>
|
|
|
|
<section>
|
|
|
|
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
|
|
|
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
|
|
|
|
_{MsgFirmAction}
|
|
|
|
_{MsgFirmAction}
|
|
|
|
<div>
|
|
|
|
<div>
|
|
|
|
^{faForm}
|
|
|
|
<p>
|
|
|
|
|
|
|
|
_{MsgFirmActionInfo}
|
|
|
|
|
|
|
|
<P>
|
|
|
|
|
|
|
|
^{faForm}
|
|
|
|
|]
|
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
---------------------------
|
|
|
|
---------------------------
|
|
|
|
-- Firm specific utilities
|
|
|
|
-- Firm specific utilities
|
|
|
|
@ -190,9 +235,9 @@ resetSupervisors cid employees = do
|
|
|
|
|
|
|
|
|
|
|
|
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
|
|
|
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
|
|
|
addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
|
|
|
addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
|
|
|
addDefaultSupervisors cid employees = do
|
|
|
|
addDefaultSupervisors cid employees = do
|
|
|
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
|
|
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
|
|
|
(do
|
|
|
|
(do
|
|
|
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
|
|
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
|
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
E.&&. spr E.^. UserCompanySupervisor
|
|
|
|
E.&&. spr E.^. UserCompanySupervisor
|
|
|
|
@ -205,12 +250,12 @@ addDefaultSupervisors cid employees = do
|
|
|
|
|
|
|
|
|
|
|
|
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
|
|
|
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
|
|
|
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
|
|
|
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
|
|
|
addDefaultSupervisorsAll mutualSupervision cids = do
|
|
|
|
addDefaultSupervisorsAll mutualSupervision cids = do
|
|
|
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
|
|
|
E.insertSelectWithConflictCount UniqueUserSupervisor
|
|
|
|
(do
|
|
|
|
(do
|
|
|
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
|
|
|
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
|
|
|
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
|
|
|
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
|
|
|
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
|
|
|
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
|
|
|
<> [ spr E.^. UserCompanySupervisor
|
|
|
|
<> [ spr E.^. UserCompanySupervisor
|
|
|
|
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
|
|
|
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
|
|
|
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
|
|
|
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
|
|
|
@ -264,7 +309,7 @@ firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr)
|
|
|
|
|
|
|
|
|
|
|
|
firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
|
|
firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
|
|
firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr)
|
|
|
|
firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr)
|
|
|
|
where
|
|
|
|
where
|
|
|
|
fltr usrc = E.exists $ do
|
|
|
|
fltr usrc = E.exists $ do
|
|
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSuper <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
|
|
E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
|
|
|
|
@ -272,7 +317,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr)
|
|
|
|
|
|
|
|
|
|
|
|
firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
|
|
firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
|
|
|
firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr)
|
|
|
|
firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr)
|
|
|
|
where
|
|
|
|
where
|
|
|
|
fltr usrc = E.exists $ do
|
|
|
|
fltr usrc = E.exists $ do
|
|
|
|
(usrSuper :& usr) <-
|
|
|
|
(usrSuper :& usr) <-
|
|
|
|
E.from $ E.table @UserSupervisor
|
|
|
|
E.from $ E.table @UserSupervisor
|
|
|
|
@ -330,7 +375,7 @@ firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value
|
|
|
|
firmCountUserSupervisors usrCmp = E.subSelectCount $ do
|
|
|
|
firmCountUserSupervisors usrCmp = E.subSelectCount $ do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
|
|
|
|
|
|
|
|
|
|
|
|
firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
|
|
|
|
firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
|
|
|
|
firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
|
|
|
|
firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
@ -367,7 +412,7 @@ postFirmR fsh = do
|
|
|
|
siteLayoutMsg (SomeMessage fsh) $ do
|
|
|
|
siteLayoutMsg (SomeMessage fsh) $ do
|
|
|
|
setTitle $ citext2Html fsh
|
|
|
|
setTitle $ citext2Html fsh
|
|
|
|
[whamlet|
|
|
|
|
[whamlet|
|
|
|
|
<h2>PROVISORISCHE DEBUG SEITE
|
|
|
|
<h2>PROVISORISCHE DEBUG SEITE
|
|
|
|
<p>Diese Seite wird in der finalen Version nicht mehr enthalten sein.
|
|
|
|
<p>Diese Seite wird in der finalen Version nicht mehr enthalten sein.
|
|
|
|
|
|
|
|
|
|
|
|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
|
|
|
|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
|
|
|
|
@ -400,21 +445,6 @@ postFirmR fsh = do
|
|
|
|
-----------------------
|
|
|
|
-----------------------
|
|
|
|
-- All Firms Table
|
|
|
|
-- All Firms Table
|
|
|
|
|
|
|
|
|
|
|
|
data FirmAllAction = FirmAllActNotify
|
|
|
|
|
|
|
|
| FirmAllActResetSupervision
|
|
|
|
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3
|
|
|
|
|
|
|
|
embedRenderMessage ''UniWorX ''FirmAllAction id
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data FirmAllActionData = FirmAllActNotifyData
|
|
|
|
|
|
|
|
| FirmAllActResetSupervisionData
|
|
|
|
|
|
|
|
{ firmAllActResetKeepOldSupers :: Maybe Bool
|
|
|
|
|
|
|
|
, firmAllActResetMutualSupervision :: Maybe Bool
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- just in case for future extensions
|
|
|
|
-- just in case for future extensions
|
|
|
|
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
|
|
|
|
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
|
|
|
|
queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
|
|
|
|
queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
|
|
|
|
@ -440,6 +470,7 @@ resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
|
|
|
|
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
|
|
|
|
mkFirmAllTable isAdmin uid = do
|
|
|
|
mkFirmAllTable isAdmin uid = do
|
|
|
|
-- now <- liftIO getCurrentTime
|
|
|
|
-- now <- liftIO getCurrentTime
|
|
|
|
|
|
|
|
mr <- getMessageRender
|
|
|
|
let
|
|
|
|
let
|
|
|
|
resultDBTable = DBTable{..}
|
|
|
|
resultDBTable = DBTable{..}
|
|
|
|
where
|
|
|
|
where
|
|
|
|
@ -448,7 +479,7 @@ mkFirmAllTable isAdmin uid = 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.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor)
|
|
|
|
E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor)
|
|
|
|
E.||. E.exists (do
|
|
|
|
E.||. E.exists (do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
|
|
@ -476,12 +507,12 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
, 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) $ \row ->
|
|
|
|
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row ->
|
|
|
|
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
|
|
|
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
|
|
|
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok
|
|
|
|
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok
|
|
|
|
-- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr
|
|
|
|
-- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr
|
|
|
|
-- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr
|
|
|
|
-- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr
|
|
|
|
-- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr
|
|
|
|
-- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr
|
|
|
|
-- , 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
|
|
|
|
@ -508,14 +539,14 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
, single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
|
|
|
|
, single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
|
|
|
|
(usr :& usrCmp) <- E.from $ E.table @User
|
|
|
|
(usr :& usrCmp) <- E.from $ E.table @User
|
|
|
|
`E.innerJoin` E.table @UserCompany
|
|
|
|
`E.innerJoin` E.table @UserCompany
|
|
|
|
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
|
|
|
|
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
|
|
E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
|
|
|
|
E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
|
|
|
|
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
|
|
|
|
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
|
|
|
|
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
|
|
|
|
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
, single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
, single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
-- let checkSuper = do -- expensive
|
|
|
|
-- let checkSuper = do -- expensive
|
|
|
|
-- usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
-- usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
-- E.where_ $ E.notExists (do
|
|
|
|
-- E.where_ $ E.notExists (do
|
|
|
|
@ -546,7 +577,7 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
)
|
|
|
|
)
|
|
|
|
, single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
|
|
|
|
, single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
|
|
|
|
]
|
|
|
|
]
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
[ fltrCompanyNameUI mPrev
|
|
|
|
[ fltrCompanyNameUI mPrev
|
|
|
|
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
|
|
|
|
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
|
|
|
|
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
|
|
|
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
|
|
|
@ -559,9 +590,7 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
, dbParamsFormAction = Nothing
|
|
|
|
, dbParamsFormAction = Nothing
|
|
|
|
, dbParamsFormAttrs = []
|
|
|
|
, dbParamsFormAttrs = []
|
|
|
|
, dbParamsFormSubmit = FormSubmit
|
|
|
|
, dbParamsFormSubmit = FormSubmit
|
|
|
|
-- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision]
|
|
|
|
, dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision]
|
|
|
|
, dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just
|
|
|
|
|
|
|
|
<$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing
|
|
|
|
|
|
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
|
|
, dbParamsFormResult = id
|
|
|
|
, dbParamsFormResult = id
|
|
|
|
, dbParamsFormIdent = def
|
|
|
|
, dbParamsFormIdent = def
|
|
|
|
@ -600,28 +629,11 @@ postFirmAllR = do
|
|
|
|
-----------------------
|
|
|
|
-----------------------
|
|
|
|
-- Firm Users Table
|
|
|
|
-- Firm Users Table
|
|
|
|
|
|
|
|
|
|
|
|
data FirmUserChangeRequest = FirmUserChangeRequest
|
|
|
|
|
|
|
|
{ fucrPostalPref :: Maybe Bool
|
|
|
|
|
|
|
|
, fucrPostalAddr :: Maybe StoredMarkup
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Default FirmUserChangeRequest where
|
|
|
|
data FirmUserAction = FirmUserActNotify
|
|
|
|
def = FirmUserChangeRequest
|
|
|
|
|
|
|
|
{ fucrPostalPref = Nothing
|
|
|
|
|
|
|
|
, fucrPostalAddr = Nothing
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest
|
|
|
|
|
|
|
|
makeFirmUserChangeRequestForm template html = do
|
|
|
|
|
|
|
|
flip (renderAForm FormStandard) html $ FirmUserChangeRequest
|
|
|
|
|
|
|
|
<$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template)
|
|
|
|
|
|
|
|
<*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data FirmUserAction = FirmUserActNotify
|
|
|
|
|
|
|
|
| FirmUserActResetSupervision
|
|
|
|
| FirmUserActResetSupervision
|
|
|
|
| FirmUserActMkSuper
|
|
|
|
| FirmUserActMkSuper
|
|
|
|
|
|
|
|
| FirmUserActChangeContact
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
|
|
|
|
|
|
|
|
@ -630,12 +642,15 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
|
|
|
|
|
|
|
|
|
|
|
|
data FirmUserActionData = FirmUserActNotifyData
|
|
|
|
data FirmUserActionData = FirmUserActNotifyData
|
|
|
|
| FirmUserActResetSupervisionData
|
|
|
|
| FirmUserActResetSupervisionData
|
|
|
|
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
|
|
|
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
|
|
|
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
|
|
|
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
|
|
|
}
|
|
|
|
}
|
|
|
|
| FirmUserActMkSuperData
|
|
|
|
| FirmUserActMkSuperData
|
|
|
|
{ firmUserActMkSuperReroute :: Maybe Bool }
|
|
|
|
{ firmUserActMkSuperReroute :: Maybe Bool }
|
|
|
|
|
|
|
|
| FirmUserActChangeContactData
|
|
|
|
|
|
|
|
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
|
|
|
|
|
|
|
, firmUserActPostalPref :: Maybe Bool
|
|
|
|
|
|
|
|
}
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
|
|
|
|
|
|
|
|
type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)
|
|
|
|
type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)
|
|
|
|
@ -649,7 +664,7 @@ queryUserUserCompany = $(sqlIJproj 2 2)
|
|
|
|
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
|
|
|
|
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
|
|
|
|
|
|
|
|
|
|
|
|
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
|
|
|
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
|
|
|
resultUserUser = _dbrOutput . _1
|
|
|
|
resultUserUser = _dbrOutput . _1
|
|
|
|
|
|
|
|
|
|
|
|
resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany)
|
|
|
|
resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany)
|
|
|
|
resultUserUserCompany = _dbrOutput . _2
|
|
|
|
resultUserUserCompany = _dbrOutput . _2
|
|
|
|
@ -660,10 +675,10 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
|
|
|
|
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
|
|
|
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
|
|
|
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
|
|
|
|
|
|
|
|
instance HasEntity UserCompanyTableData User where
|
|
|
|
instance HasEntity UserCompanyTableData User where
|
|
|
|
hasEntity = resultUserUser
|
|
|
|
hasEntity = resultUserUser
|
|
|
|
|
|
|
|
|
|
|
|
instance HasUser UserCompanyTableData where
|
|
|
|
instance HasUser UserCompanyTableData where
|
|
|
|
hasUser = resultUserUser . _entityVal
|
|
|
|
hasUser = resultUserUser . _entityVal
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -675,7 +690,7 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }
|
|
|
|
return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }
|
|
|
|
procOptions = fmap mkOptionList . traverse mkSprOption
|
|
|
|
procOptions = fmap mkOptionList . traverse mkSprOption
|
|
|
|
|
|
|
|
|
|
|
|
rawSupers <- E.select $ do
|
|
|
|
rawSupers <- E.select $ do
|
|
|
|
usr <- E.from $ E.table @User
|
|
|
|
usr <- E.from $ E.table @User
|
|
|
|
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
|
|
|
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
|
|
|
return (usr E.^. UserId, usr E.^. UserDisplayName)
|
|
|
|
return (usr E.^. UserId, usr E.^. UserDisplayName)
|
|
|
|
@ -694,7 +709,7 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
|
|
|
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
dbtColonnade = formColonnade $ mconcat
|
|
|
|
dbtColonnade = formColonnade $ mconcat
|
|
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
|
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
|
|
|
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
|
|
|
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
|
|
|
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
|
|
|
|
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
|
|
|
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
|
|
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
|
|
|
@ -715,16 +730,16 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
]
|
|
|
|
]
|
|
|
|
dbtFilter = mconcat
|
|
|
|
dbtFilter = mconcat
|
|
|
|
[ single $ fltrUserNameEmail queryUserUser
|
|
|
|
[ single $ fltrUserNameEmail queryUserUser
|
|
|
|
, singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
, singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
let checkSuper = do
|
|
|
|
let checkSuper = do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
in case criterion of
|
|
|
|
in case criterion of
|
|
|
|
Nothing -> E.true
|
|
|
|
Nothing -> E.true
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
, singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
, singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
let checkSuper = do
|
|
|
|
let checkSuper = do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.&&. E.exists (do
|
|
|
|
E.&&. E.exists (do
|
|
|
|
@ -736,8 +751,8 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
Nothing -> E.true
|
|
|
|
Nothing -> E.true
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
, singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
, singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
let checkSuper = do
|
|
|
|
let checkSuper = do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.&&. E.notExists (do
|
|
|
|
E.&&. E.notExists (do
|
|
|
|
@ -750,20 +765,20 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
, singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
, singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
case criterion of
|
|
|
|
case criterion of
|
|
|
|
Just uid -> do
|
|
|
|
Just uid -> do
|
|
|
|
-- uid <- decryptUser uuid
|
|
|
|
-- uid <- decryptUser uuid
|
|
|
|
E.exists $ do
|
|
|
|
E.exists $ do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
|
|
|
_otherwise -> E.true
|
|
|
|
_otherwise -> E.true
|
|
|
|
, singletonMap "supervisors-are" $ FilterColumn $ \row criteria ->
|
|
|
|
, singletonMap "supervisors-are" $ FilterColumn $ \row criteria ->
|
|
|
|
case criteria of
|
|
|
|
case criteria of
|
|
|
|
_ | Set.null criteria -> E.true
|
|
|
|
_ | Set.null criteria -> E.true
|
|
|
|
| otherwise -> do
|
|
|
|
| otherwise -> do
|
|
|
|
-- uids <- traverse decryptUser criteria
|
|
|
|
-- uids <- traverse decryptUser criteria
|
|
|
|
E.exists $ do
|
|
|
|
E.exists $ do
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
|
|
|
|
@ -771,7 +786,7 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
-- superField = selectField $ ????
|
|
|
|
-- superField = selectField $ ????
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
|
|
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
|
|
|
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
|
|
|
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
|
|
|
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
|
|
|
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
|
|
|
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
|
|
|
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
|
|
|
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
|
|
|
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
|
|
|
@ -782,10 +797,13 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
acts = mconcat
|
|
|
|
acts = mconcat
|
|
|
|
[ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
|
|
|
[ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
|
|
|
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
|
|
|
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
|
|
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False)
|
|
|
|
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
|
|
|
-- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True )
|
|
|
|
-- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
|
|
|
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
|
|
|
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
|
|
|
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
|
|
|
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
|
|
|
|
|
|
|
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
|
|
|
|
|
|
|
|
<$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing
|
|
|
|
|
|
|
|
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
|
|
|
]
|
|
|
|
]
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
{ dbParamsFormMethod = POST
|
|
|
|
{ dbParamsFormMethod = POST
|
|
|
|
@ -812,7 +830,7 @@ mkFirmUserTable isAdmin cid = do
|
|
|
|
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
|
|
|
|
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
|
|
|
|
return (act, s)
|
|
|
|
return (act, s)
|
|
|
|
|
|
|
|
|
|
|
|
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
|
|
|
|
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData))
|
|
|
|
resultDBTableValidator = def
|
|
|
|
resultDBTableValidator = def
|
|
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
@ -832,7 +850,7 @@ postFirmUsersR fsh = do
|
|
|
|
, E.Value nrCompanyEmployeeRerPost
|
|
|
|
, E.Value nrCompanyEmployeeRerPost
|
|
|
|
, E.Value nrCompanyDefaultReroutes
|
|
|
|
, E.Value nrCompanyDefaultReroutes
|
|
|
|
, E.Value nrCompanyActiveReroutes
|
|
|
|
, E.Value nrCompanyActiveReroutes
|
|
|
|
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
|
|
|
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
|
|
|
<$> fromMaybeM notFound (E.selectOne $ do
|
|
|
|
<$> fromMaybeM notFound (E.selectOne $ do
|
|
|
|
cmpy <- E.from $ E.table @Company
|
|
|
|
cmpy <- E.from $ E.table @Company
|
|
|
|
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
|
|
|
|
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
|
|
|
|
@ -846,17 +864,17 @@ postFirmUsersR fsh = do
|
|
|
|
, cmpy & firmCountDefaultReroutes
|
|
|
|
, cmpy & firmCountDefaultReroutes
|
|
|
|
, cmpy & firmCountActiveReroutes
|
|
|
|
, cmpy & firmCountActiveReroutes
|
|
|
|
))
|
|
|
|
))
|
|
|
|
-- superVs <- E.select $ do
|
|
|
|
-- superVs <- E.select $ do
|
|
|
|
-- usr <- E.from $ E.table @User
|
|
|
|
-- usr <- E.from $ E.table @User
|
|
|
|
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
|
|
|
|
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
|
|
|
|
-- return usr
|
|
|
|
-- return usr
|
|
|
|
<*> mkFirmUserTable isAdmin cid
|
|
|
|
<*> mkFirmUserTable isAdmin cid
|
|
|
|
|
|
|
|
|
|
|
|
formResult fusrRes $ \case
|
|
|
|
formResult fusrRes $ \case
|
|
|
|
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
|
|
|
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
|
|
|
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
|
|
|
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
|
|
|
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
|
|
|
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
|
|
|
addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing
|
|
|
|
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
(FirmUserActNotifyData , uids) -> do
|
|
|
|
(FirmUserActNotifyData , uids) -> do
|
|
|
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
|
|
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
|
|
|
@ -865,34 +883,21 @@ postFirmUsersR fsh = do
|
|
|
|
runDB $ do
|
|
|
|
runDB $ do
|
|
|
|
delSupers <- if firmUserActResetKeepOldSupers == Just False
|
|
|
|
delSupers <- if firmUserActResetKeepOldSupers == Just False
|
|
|
|
then deleteSupervisors uids
|
|
|
|
then deleteSupervisors uids
|
|
|
|
else return 0
|
|
|
|
else return 0
|
|
|
|
newSupers <- addDefaultSupervisors cid uids
|
|
|
|
newSupers <- addDefaultSupervisors cid uids
|
|
|
|
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
|
|
|
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
|
|
|
|
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
|
|
|
|
((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def)
|
|
|
|
let changes = catMaybes
|
|
|
|
let addFormAnchor = "firm-user-change-form" :: Text
|
|
|
|
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
|
|
|
routeForm = FirmUsersR fsh :#: addFormAnchor
|
|
|
|
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
|
|
|
fucrForm = wrapForm fucrWgt FormSettings
|
|
|
|
]
|
|
|
|
{ formMethod = POST
|
|
|
|
in unless (null changes) $ do
|
|
|
|
, formAction = Just . SomeRoute $ routeForm
|
|
|
|
nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
|
|
|
|
, formEncoding = fucrEnctype
|
|
|
|
addMessageI Success $ MsgFirmUserChanges nrChanged
|
|
|
|
, formAttrs = []
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
, formSubmit = FormSubmit
|
|
|
|
|
|
|
|
, formAnchor = Just addFormAnchor
|
|
|
|
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
|
|
|
}
|
|
|
|
|
|
|
|
formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do
|
|
|
|
|
|
|
|
when (isJust fucrPPref || isJust fucrPAddr) $ do
|
|
|
|
|
|
|
|
let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <>
|
|
|
|
|
|
|
|
foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address!
|
|
|
|
|
|
|
|
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
|
|
|
|
|
|
|
E.set usr changes
|
|
|
|
|
|
|
|
E.where_ $ E.exists $ do
|
|
|
|
|
|
|
|
usrCmpy <- E.from $ E.table @UserCompany
|
|
|
|
|
|
|
|
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
|
|
|
|
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
|
|
|
|
|
|
|
addMessageI Info $ MsgFirmUserChanges nrChanged
|
|
|
|
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
siteLayout (citext2widget companyName) $ do
|
|
|
|
siteLayout (citext2widget companyName) $ do
|
|
|
|
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
|
|
|
|
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
|
|
|
|
@ -903,9 +908,9 @@ postFirmUsersR fsh = do
|
|
|
|
-----------------------------
|
|
|
|
-----------------------------
|
|
|
|
-- Firm Supervisors Table
|
|
|
|
-- Firm Supervisors Table
|
|
|
|
|
|
|
|
|
|
|
|
data FirmSuperAction = FirmSuperActNotify
|
|
|
|
data FirmSuperAction = FirmSuperActNotify
|
|
|
|
| FirmSuperActRMSuperDef
|
|
|
|
| FirmSuperActRMSuperDef
|
|
|
|
|
|
|
|
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
|
|
|
|
|
|
|
|
@ -915,32 +920,10 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id
|
|
|
|
data FirmSuperActionData = FirmSuperActNotifyData
|
|
|
|
data FirmSuperActionData = FirmSuperActNotifyData
|
|
|
|
| FirmSuperActRMSuperDefData
|
|
|
|
| FirmSuperActRMSuperDefData
|
|
|
|
{ firmSuperActRMSuperActive :: Maybe Bool }
|
|
|
|
{ firmSuperActRMSuperActive :: Maybe Bool }
|
|
|
|
|
|
|
|
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
deriving (Eq, Ord, Show, Generic)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
data AddSupervisorRequest = AddSupervisorRequest
|
|
|
|
|
|
|
|
{ asReqSupers :: Set Text
|
|
|
|
|
|
|
|
, asReqReroute :: Bool
|
|
|
|
|
|
|
|
, asReqPostal :: Maybe Bool
|
|
|
|
|
|
|
|
} deriving (Eq, Ord, Show, Generic)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Default AddSupervisorRequest where
|
|
|
|
|
|
|
|
def = AddSupervisorRequest
|
|
|
|
|
|
|
|
{ asReqSupers = mempty
|
|
|
|
|
|
|
|
, asReqReroute = True
|
|
|
|
|
|
|
|
, asReqPostal = Nothing
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest
|
|
|
|
|
|
|
|
makeAddSupervisorForm template html = do
|
|
|
|
|
|
|
|
flip (renderAForm FormStandard) html $ AddSupervisorRequest
|
|
|
|
|
|
|
|
<$> areq (textField & cfAnySeparatedSet)
|
|
|
|
|
|
|
|
(fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template)
|
|
|
|
|
|
|
|
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template)
|
|
|
|
|
|
|
|
<*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany))
|
|
|
|
type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany))
|
|
|
|
|
|
|
|
|
|
|
|
querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
|
|
|
|
querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
|
|
|
|
@ -955,7 +938,7 @@ type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
|
|
|
|
)
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
|
|
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
|
|
|
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
|
|
|
resultSuperUser = _dbrOutput . _1
|
|
|
|
resultSuperUser = _dbrOutput . _1
|
|
|
|
|
|
|
|
|
|
|
|
resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64
|
|
|
|
resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64
|
|
|
|
resultSuperCompanySupervised = _dbrOutput . _2 . _unValue
|
|
|
|
resultSuperCompanySupervised = _dbrOutput . _2 . _unValue
|
|
|
|
@ -972,10 +955,10 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
|
|
|
|
resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
|
|
|
|
resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
|
|
|
|
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
|
|
|
|
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
|
|
|
|
|
|
|
|
|
|
|
|
instance HasEntity SuperCompanyTableData User where
|
|
|
|
instance HasEntity SuperCompanyTableData User where
|
|
|
|
hasEntity = resultSuperUser
|
|
|
|
hasEntity = resultSuperUser
|
|
|
|
|
|
|
|
|
|
|
|
instance HasUser SuperCompanyTableData where
|
|
|
|
instance HasUser SuperCompanyTableData where
|
|
|
|
hasUser = resultSuperUser . _entityVal
|
|
|
|
hasUser = resultSuperUser . _entityVal
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -997,7 +980,7 @@ mkFirmSuperTable isAdmin cid = do
|
|
|
|
)
|
|
|
|
)
|
|
|
|
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
|
|
|
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
|
|
|
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
|
|
|
|
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
|
|
|
|
cmps <- E.select $ do
|
|
|
|
cmps <- E.select $ do
|
|
|
|
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
|
|
|
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
|
|
|
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
|
|
|
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
|
|
|
@ -1020,7 +1003,7 @@ mkFirmSuperTable isAdmin cid = do
|
|
|
|
]
|
|
|
|
]
|
|
|
|
dbtSorting = mconcat
|
|
|
|
dbtSorting = mconcat
|
|
|
|
[ single $ sortUserNameLink querySuperUser
|
|
|
|
[ single $ sortUserNameLink querySuperUser
|
|
|
|
, single $ sortUserEmail querySuperUser
|
|
|
|
, single $ sortUserEmail querySuperUser
|
|
|
|
, singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)
|
|
|
|
, singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)
|
|
|
|
, singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)
|
|
|
|
, singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)
|
|
|
|
, singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)
|
|
|
|
, singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)
|
|
|
|
@ -1045,7 +1028,7 @@ mkFirmSuperTable isAdmin cid = do
|
|
|
|
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
|
|
|
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
|
|
|
acts = mconcat
|
|
|
|
acts = mconcat
|
|
|
|
[ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
|
|
|
[ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
|
|
|
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
|
|
|
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
|
|
|
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
|
|
|
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
|
|
|
]
|
|
|
|
]
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
@ -1072,7 +1055,7 @@ mkFirmSuperTable isAdmin cid = do
|
|
|
|
(First (Just act), m) <- inp
|
|
|
|
(First (Just act), m) <- inp
|
|
|
|
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
|
|
|
|
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
|
|
|
|
return (act, s)
|
|
|
|
return (act, s)
|
|
|
|
|
|
|
|
|
|
|
|
resultDBTableValidator = def
|
|
|
|
resultDBTableValidator = def
|
|
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
@ -1089,7 +1072,7 @@ postFirmSupersR fsh = do
|
|
|
|
|
|
|
|
|
|
|
|
formResult fsprRes $ \case
|
|
|
|
formResult fsprRes $ \case
|
|
|
|
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
|
|
|
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
|
|
|
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
|
|
|
|
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
|
|
|
|
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
|
|
|
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
|
|
|
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
|
|
|
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
|
|
|
<*> if firmSuperActRMSuperActive /= Just True
|
|
|
|
<*> if firmSuperActRMSuperActive /= Just True
|
|
|
|
@ -1100,49 +1083,16 @@ postFirmSupersR fsh = do
|
|
|
|
E.&&. E.exists (do
|
|
|
|
E.&&. E.exists (do
|
|
|
|
usr <- E.from $ E.table @UserCompany
|
|
|
|
usr <- E.from $ E.table @UserCompany
|
|
|
|
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
|
|
|
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
|
|
|
)
|
|
|
|
)
|
|
|
|
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
|
|
|
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
|
|
|
|
|
|
|
|
|
|
|
(FirmSuperActNotifyData , uids) -> do
|
|
|
|
(FirmSuperActNotifyData , uids) -> do
|
|
|
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
|
|
|
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
|
|
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
|
|
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
|
|
|
|
|
|
|
|
|
|
|
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision]
|
|
|
|
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
|
|
|
|
|
|
|
|
|
|
|
|
((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def)
|
|
|
|
|
|
|
|
let addSuperAnchor = "add-supervisors-form" :: Text
|
|
|
|
|
|
|
|
routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor
|
|
|
|
|
|
|
|
addSuperForm = wrapForm asReqWgt FormSettings
|
|
|
|
|
|
|
|
{ formMethod = POST
|
|
|
|
|
|
|
|
, formAction = Just . SomeRoute $ routeAddSuperForm
|
|
|
|
|
|
|
|
, formEncoding = asReqEnctype
|
|
|
|
|
|
|
|
, formAttrs = []
|
|
|
|
|
|
|
|
, formSubmit = FormSubmit
|
|
|
|
|
|
|
|
, formAnchor = Just addSuperAnchor
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
formResult asReqRes $ \AddSupervisorRequest{..} -> do
|
|
|
|
|
|
|
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers
|
|
|
|
|
|
|
|
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
|
|
|
|
|
|
|
usersFound = mapMaybe snd usersFound'
|
|
|
|
|
|
|
|
unless (null usersNotFound) $
|
|
|
|
|
|
|
|
let msgContent = [whamlet|
|
|
|
|
|
|
|
|
$newline never
|
|
|
|
|
|
|
|
<ul>
|
|
|
|
|
|
|
|
$forall (usr,_) <- usersNotFound
|
|
|
|
|
|
|
|
<li>#{usr}
|
|
|
|
|
|
|
|
|]
|
|
|
|
|
|
|
|
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
|
|
|
|
|
|
|
when (null usersFound) $ do
|
|
|
|
|
|
|
|
addMessageI Warning MsgASReqEmpty
|
|
|
|
|
|
|
|
redirect routeAddSuperForm
|
|
|
|
|
|
|
|
runDB $ do
|
|
|
|
|
|
|
|
putMany [UserCompany uid cid True asReqReroute | uid <- usersFound]
|
|
|
|
|
|
|
|
whenIsJust asReqPostal $ \prefPostal ->
|
|
|
|
|
|
|
|
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
|
|
|
|
|
|
|
|
addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal
|
|
|
|
|
|
|
|
redirect $ FirmSupersR fsh
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
siteLayout (citext2widget fsh) $ do
|
|
|
|
siteLayout (citext2widget fsh) $ do
|
|
|
|
setTitle $ citext2Html $ fsh <> " Supers"
|
|
|
|
setTitle $ citext2Html $ fsh <> " Supers"
|
|
|
|
@ -1167,9 +1117,9 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR)
|
|
|
|
handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
|
|
|
|
handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
|
|
|
|
handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."]
|
|
|
|
handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."]
|
|
|
|
handleFirmCommR ultDest cs = do
|
|
|
|
handleFirmCommR ultDest cs = do
|
|
|
|
let
|
|
|
|
let
|
|
|
|
queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds
|
|
|
|
queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds
|
|
|
|
queryGiven usrs = do
|
|
|
|
queryGiven usrs = do
|
|
|
|
usr <- E.from $ E.table @User
|
|
|
|
usr <- E.from $ E.table @User
|
|
|
|
E.where_ $ usr E.^. UserId `E.in_` E.valList usrs
|
|
|
|
E.where_ $ usr E.^. UserId `E.in_` E.valList usrs
|
|
|
|
return usr
|
|
|
|
return usr
|
|
|
|
@ -1179,14 +1129,14 @@ handleFirmCommR ultDest cs = do
|
|
|
|
csKeys = CompanyKey <$> cs
|
|
|
|
csKeys = CompanyKey <$> cs
|
|
|
|
mbUser <- maybeAuthId
|
|
|
|
mbUser <- maybeAuthId
|
|
|
|
-- get employees of chosen companies
|
|
|
|
-- get employees of chosen companies
|
|
|
|
empys <- mkCompanyUsrList <$> runDB (E.select $ do
|
|
|
|
empys <- mkCompanyUsrList <$> runDB (E.select $ do
|
|
|
|
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
|
|
|
|
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
|
|
|
|
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
|
|
|
|
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
|
|
|
|
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
|
|
|
|
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
|
|
|
|
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
|
|
|
|
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
-- get supervisors of employees
|
|
|
|
-- get supervisors of employees
|
|
|
|
sprs <- mkCompanyUsrList <$> runDB (E.select $ do
|
|
|
|
sprs <- mkCompanyUsrList <$> runDB (E.select $ do
|
|
|
|
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
|
|
|
|
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
|
|
|
|
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
|
|
|
|
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
|
|
|
|
E.||. (spr E.^. UserId E.=?. E.val mbUser)
|
|
|
|
E.||. (spr E.^. UserId E.=?. E.val mbUser)
|
|
|
|
@ -1197,24 +1147,24 @@ handleFirmCommR ultDest cs = do
|
|
|
|
)
|
|
|
|
)
|
|
|
|
E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany]
|
|
|
|
E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany]
|
|
|
|
return (cmp E.?. UserCompanyCompany, spr E.^. UserId)
|
|
|
|
return (cmp E.?. UserCompanyCompany, spr E.^. UserId)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
|
|
commR CommunicationRoute
|
|
|
|
commR CommunicationRoute
|
|
|
|
{ crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification }
|
|
|
|
{ crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification }
|
|
|
|
, crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle }
|
|
|
|
, crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle }
|
|
|
|
, crUltDest = ultDest
|
|
|
|
, crUltDest = ultDest
|
|
|
|
, crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
|
|
, crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
|
|
, crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
|
|
, crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
|
|
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
|
|
|
|
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
|
|
|
|
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
|
|
|
|
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
|
|
|
|
[(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++
|
|
|
|
[(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++
|
|
|
|
[(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ]
|
|
|
|
[(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ]
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
{- Auswahlbox für Mitteilung:
|
|
|
|
{- Auswahlbox für Mitteilung:
|
|
|
|
Wenn Firma gewählt, dann zeige:
|
|
|
|
Wenn Firma gewählt, dann zeige:
|
|
|
|
Alle Supervisor von Leuten in X, gruppiert nach deren Firma
|
|
|
|
Alle Supervisor von Leuten in X, gruppiert nach deren Firma
|
|
|
|
Alle Teilnehmer von X
|
|
|
|
Alle Teilnehmer von X
|
|
|
|
Wenn keine Firma gewählt, dann zeige:
|
|
|
|
Wenn keine Firma gewählt, dann zeige:
|
|
|
|
Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
|
|
|
|
Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
|
|
|
|
Alle gewählten Personen, gruppiert nach deren Firma
|
|
|
|
Alle gewählten Personen, gruppiert nach deren Firma
|
|
|
|
|
