From 631d157688b79dd80916ee27ef08f209ccfb1f3b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 18:38:21 +0100 Subject: [PATCH] chore(firm): add messaging action (WIP) --- .../uniworx/categories/firm/de-de-formal.msg | 2 + messages/uniworx/categories/firm/en-eu.msg | 2 + routes | 5 +- src/Handler/Firm.hs | 100 ++++++++++++++++-- src/Handler/Utils/Communication.hs | 1 + 5 files changed, 103 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 4fb1d392d..65e8291f1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index a4df65482..68e4add9b 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -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} diff --git a/routes b/routes index 6b89c13f6..694386474 100644 --- a/routes +++ b/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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1b27ad612..b6eb43e95 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -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
^{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 + -} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 93577f8ed..3ec2dd854 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -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