chore(firm): add messaging action (WIP)
This commit is contained in:
parent
3865bda64d
commit
631d157688
@ -13,6 +13,8 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||
FirmSuperActNotify: Mitteilung versenden
|
||||
FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen
|
||||
FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen
|
||||
FirmsNotification: Firmen Benachrichtigung versenden
|
||||
FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden
|
||||
FilterSupervisor: Hat aktiven Ansprechpartner
|
||||
FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört
|
||||
FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
|
||||
|
||||
@ -13,6 +13,8 @@ FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmSuperActNotify: Send message
|
||||
FirmSuperActRMSuperDef: Remove as default supervisor
|
||||
FirmSuperActRMSuperAll: Remove all active supervisions for this company
|
||||
FirmsNotification: Send company notification
|
||||
FirmNotification fsh: Send notification to company #{fsh}
|
||||
FilterSupervisor: Has active supervisor
|
||||
FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
|
||||
FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
|
||||
|
||||
5
routes
5
routes
@ -113,10 +113,13 @@
|
||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||
|
||||
/firm FirmAllR GET POST !supervisor
|
||||
/firms FirmAllR GET POST !supervisor
|
||||
/firms/comm FirmsCommR GET POST
|
||||
/firm/#CompanyShorthand FirmR GET POST
|
||||
/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor
|
||||
/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor
|
||||
/firm/#CompanyShorthand/comm FirmCommR GET POST
|
||||
|
||||
|
||||
/exam-office ExamOfficeR !exam-office:
|
||||
/ EOExamsR GET POST !system-exam-office
|
||||
|
||||
@ -11,6 +11,8 @@ module Handler.Firm
|
||||
, getFirmR , postFirmR
|
||||
, getFirmUsersR , postFirmUsersR
|
||||
, getFirmSupersR, postFirmSupersR
|
||||
, getFirmCommR , postFirmCommR
|
||||
, getFirmsCommR, postFirmsCommR
|
||||
)
|
||||
where
|
||||
|
||||
@ -18,6 +20,7 @@ import Import
|
||||
|
||||
-- import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Communication
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -494,8 +497,10 @@ mkFirmUserTable isAdmin cid = do
|
||||
Just True -> E.exists checkSuper
|
||||
Just False -> E.notExists checkSuper
|
||||
]
|
||||
-- superField = selectField $ ????
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
||||
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
|
||||
, 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-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
|
||||
@ -541,7 +546,7 @@ getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
|
||||
getFirmUsersR = postFirmUsersR
|
||||
postFirmUsersR fsh = do
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
let fshId = CompanyKey fsh
|
||||
let cid = CompanyKey fsh
|
||||
(( Entity{entityVal=Company{..}}
|
||||
, E.Value nrCompanyUsers
|
||||
, E.Value nrCompanySupervisors
|
||||
@ -551,10 +556,10 @@ postFirmUsersR fsh = do
|
||||
, E.Value nrCompanyEmployeeRerPost
|
||||
, E.Value nrCompanyDefaultReroutes
|
||||
, E.Value nrCompanyActiveReroutes
|
||||
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
||||
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
||||
<$> fromMaybeM notFound (E.selectOne $ do
|
||||
cmpy <- E.from $ E.table @Company
|
||||
E.where_ $ cmpy E.^. CompanyId E.==. E.val fshId
|
||||
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
|
||||
return ( cmpy
|
||||
, cmpy & firmCountUsers
|
||||
, cmpy & firmCountSupervisors
|
||||
@ -565,11 +570,18 @@ postFirmUsersR fsh = do
|
||||
, cmpy & firmCountDefaultReroutes
|
||||
, cmpy & firmCountActiveReroutes
|
||||
))
|
||||
<*> mkFirmUserTable isAdmin fshId
|
||||
-- superVs <- E.select $ do
|
||||
-- usr <- E.from $ E.table @User
|
||||
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
|
||||
-- return usr
|
||||
<*> mkFirmUserTable isAdmin cid
|
||||
|
||||
formResult fusrRes $ \case
|
||||
(FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO"
|
||||
formResult fusrRes $ \case
|
||||
(FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO"
|
||||
(FirmUserActNotifyData , fids) -> do
|
||||
cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser]
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
|
||||
$(widgetFile "firm-users")
|
||||
@ -755,3 +767,79 @@ postFirmSupersR fsh = do
|
||||
<section>
|
||||
^{fsprTable}
|
||||
|]
|
||||
|
||||
|
||||
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
|
||||
getFirmCommR = postFirmCommR
|
||||
postFirmCommR fsh = handleFirmCommR (SomeRoute FirmUsersR) (Just fsh)
|
||||
|
||||
|
||||
getFirmsCommR, postFirmsCommR :: Handler Html
|
||||
getFirmsCommR = postFirmsCommR
|
||||
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing
|
||||
|
||||
|
||||
handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html
|
||||
handleFirmCommR ultDest mbFsh = do
|
||||
let decrypt' :: CryptoUUIDUser -> Handler UserId
|
||||
decrypt' = decrypt
|
||||
|
||||
mbCid = CompanyKey <$> mbFsh
|
||||
|
||||
-- queryEmpys :: CompanyId -> Handler [UserId]
|
||||
queryEmpys cid = E.unValue <<$>> runDB (E.select $ do
|
||||
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid
|
||||
return $ emp E.^. UserId
|
||||
)
|
||||
|
||||
chosen <- mapM decrypt =<< lookupGlobalGetParams GetRecipient -- retrieve selected users
|
||||
empys <- maybe (return chosen) queryEmpys mbCid -- get all employees or stick with selected users, if no company was pre-selected (to limit choices)
|
||||
|
||||
cmpys <- runDB $ E.select $ do
|
||||
cmpy <- E.from $ E.table @Company
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList chosen
|
||||
E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||
return $ cmpy E.^.CompanyId
|
||||
|
||||
let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
queryCmpy sORe acid = do
|
||||
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid
|
||||
E.&&. (if sORe
|
||||
then -- supervisors only
|
||||
E.exists $ do
|
||||
usrSpr <- E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
E.&&. usrSpr E.^. UserSupervisorUser E.in_ E.valList empys
|
||||
else -- chosen employees for this company only
|
||||
usr E.^. UserId E.in_ E.valList empys
|
||||
)
|
||||
|
||||
commR CommunicationRoute
|
||||
{ crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh
|
||||
, crUltDest = ultDest
|
||||
, crJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
, crTestJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
|
||||
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
|
||||
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <>
|
||||
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ]
|
||||
}
|
||||
|
||||
{-
|
||||
??? x
|
||||
|
||||
Alle Supervisor von Leuten in X, gruppiert nach Firma
|
||||
Alle Teilnehmer von X
|
||||
|
||||
Ansprechpartner aus X
|
||||
- Fred
|
||||
Ansprechpartner aus Y
|
||||
- Otto
|
||||
Angestellte aus X
|
||||
- Fred
|
||||
- Meier
|
||||
-}
|
||||
|
||||
@ -30,6 +30,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect
|
||||
| RGTutorialParticipants CryptoUUIDTutorial
|
||||
| RGExamRegistered CryptoUUIDExam
|
||||
| RGSheetSubmittor CryptoUUIDSheet
|
||||
| RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
instance LowerBounded RecipientGroup where
|
||||
|
||||
Loading…
Reference in New Issue
Block a user