fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(firm): firm messaging now works fine

Browse Source
This commit is contained in:
Steffen Jost 2023-11-14 16:55:14 +01:00
parent 42ff02d27e
commit 65cdc8ddfe
10 changed files with 160 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/firm/de-de-formal.msg
View File

@ -21,4 +21,5 @@ FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der s
FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
FilterFirmPostalAddress: Postalische Firmenadresse vorhanden
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}

1
messages/uniworx/categories/firm/en-eu.msg
View File

@ -21,4 +21,5 @@ FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
FilterForeignSupervisor: Has company-external supervisors
FilterFirmPostalAddress: Postal company addresse known
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
FirmSupervisorIndependent: Independent supervisors
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users

2
routes
View File

@ -114,7 +114,7 @@
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
/firms FirmAllR GET POST !supervisor
/firms/comm FirmsCommR GET POST
/firms/comm/+Companies FirmsCommR GET POST
/firm/#CompanyShorthand FirmR GET POST
/firm/#CompanyShorthand/comm FirmCommR GET POST
/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor

2
src/Foundation/Navigation.hs
View File

@ -124,7 +124,7 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh

84
src/Handler/Firm.hs
View File

@ -380,13 +380,13 @@ postFirmAllR = do
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
formResult firmRes $ \case
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
(FirmAllActNotifyData , fids) -> do
(FirmAllActNotifyData , Set.toList -> fids) -> do
usrs <- runDB $ E.select $ E.distinct $ 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.in_` E.valList (Set.toList fids)
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
return $ usr E.^. UserId
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
$(i18nWidgetFile "firm-all")
@ -792,48 +792,54 @@ postFirmSupersR fsh = do
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
getFirmCommR = postFirmCommR
postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh)
postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh]
getFirmsCommR, postFirmsCommR :: Handler Html
getFirmsCommR, postFirmsCommR :: Companies -> Handler Html
getFirmsCommR = postFirmsCommR
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR)
handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html
handleFirmCommR ultDest mbFsh = do
let decryptUserId :: CryptoUUIDUser -> Handler UserId
decryptUserId = decrypt
mbCid = CompanyKey <$> mbFsh
{-
queryEmpys :: CompanyId -> Handler [UserId]
queryEmpys cid = E.unValue <<$>> runDB (E.select $ do
handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."]
handleFirmCommR ultDest cs = do
let csKey = CompanyKey <$> cs
-- get employees of chosen companies
empys <- 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
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey
return $ emp E.^. UserId
)
-}
selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users
empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices)
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
))
cmpys <- E.unValue <<$>> runDB (E.select $ do
-- get supervisors of employees
sprs <- E.unValue <<$>> runDB (E.select $ do
spr <- E.from $ E.table @User
E.where_ $ E.exists $ do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
return $ spr E.^. UserId
)
-- get companies of all supervisors
sprCmpys <- E.unValue <<$>> runDB (E.select $ do
cmpy <- E.from $ E.table @Company
E.where_ $ E.exists $ do
usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected
E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs
return $ cmpy E.^.CompanyId
)
let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
let
queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation
queryLoners = do
spr <- E.from $ E.table @User
E.where_ $ spr E.^. UserId `E.in_` E.valList empys
E.&&. E.notExists (do
sprCmp <- E.from $ E.table @UserCompany
E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId
)
return $ spr
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
@ -843,20 +849,20 @@ handleFirmCommR ultDest mbFsh = do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
else -- selected employees for this company only
usr E.^. UserId `E.in_` E.valList empys
else E.true
)
return usr
commR CommunicationRoute
{ crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh
{ crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c; _ -> MsgFirmsNotification }
, crUltDest = ultDest
, crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crJobs = crJobsFirmCommunication 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
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <>
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid]
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++
(RGFirmIndependent, queryLoners) :
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ]
}
{- Auswahlbox für Mitteilung:

35
src/Handler/Utils/Communication.hs
View File

@ -32,7 +32,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect
| RGTutorialParticipants CryptoUUIDTutorial
| RGExamRegistered CryptoUUIDExam
| RGSheetSubmittor CryptoUUIDSheet
| RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand
| RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent
deriving (Eq, Ord, Read, Show, Generic)
instance LowerBounded RecipientGroup where
@ -110,8 +110,8 @@ crTestJobsCourseCommunication jCourse comm = do
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crJobsFirmCommunication jCompany Communication{..} = do
crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crJobsFirmCommunication jCompanies Communication{..} = do
jSender <- requireAuthId
let jMailContent = cContent
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
@ -122,12 +122,12 @@ crJobsFirmCommunication jCompany Communication{..} = do
forM_ allRecipients $ \jRecipientEmail ->
yield JobSendFirmCommunication{..}
crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crTestFirmCommunication jCompany comm = do
crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crTestFirmCommunication jCompanies comm = do
jSender <- requireAuthId
MsgRenderer mr <- getMsgRenderer
let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject)
crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail)
crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail)
@ -139,26 +139,24 @@ commR CommunicationRoute{..} = do
uid <- decrypt cID
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
getEntity uid
cUser <- maybeAuth
(chosenRecipients, suggestedRecipients) <- runDB $ (,)
<$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient))
<*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry))
$logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")")
MsgRenderer mr <- getMsgRenderer
mbCurrentRoute <- getCurrentRoute
(suggestedRecipients, chosenRecipients) <- runDB $ (,)
<$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)
<*> fmap (maybe id cons cUser . catMaybes) (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)
$logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")")
let
lookupUser :: UserId -> (UserDisplayName,UserSurname)
lookupUser =
let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients
usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is displayed
usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display
usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname)
in usrNames . flip Map.lookup usrMap
let chosenRecipients' = Map.fromList $
chosenRecipients' = Map.fromList $
[ ( (BoundedPosition $ RecipientGroup g, pos)
, (Right recp, recp `elem` map entityKey chosenRecipients)
)
@ -172,7 +170,7 @@ commR CommunicationRoute{..} = do
]
activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
@ -235,7 +233,6 @@ commR CommunicationRoute{..} = do
recipientsListMsg <- messageI Info MsgCommRecipientsList
$logWarnS "COMM" "Communication handler some definitions done"
attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
let attachmentField = genericFileField $ return FileField
{ fieldIdent = Nothing
@ -246,7 +243,7 @@ commR CommunicationRoute{..} = do
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
, fieldAllEmptyOk = True
}
$logWarnS "COMM" "Communication handler some parameters done" -- SEEN
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
<$> recipientAForm
<* aformMessage recipientsListMsg
@ -256,7 +253,6 @@ commR CommunicationRoute{..} = do
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
(fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
)
$logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE
formResult commRes $ \case
(comm, BtnCommunicationSend) -> do
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
@ -265,14 +261,13 @@ commR CommunicationRoute{..} = do
(comm, BtnCommunicationTest) -> do
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs
addMessageI Info MsgCommTestSuccess
$logWarnS "COMM" "Communication handler form result done"
let formWdgt = wrapForm commWdgt def
{ formMethod = POST
, formAction = SomeRoute <$> mbCurrentRoute
, formEncoding = commEncoding
, formSubmit = FormNoSubmit
}
$logWarnS "COMM" "Communication handler finished"
siteLayoutMsg crHeading $ do
setTitleI crHeading
let commTestTip = $(i18nWidgetFile "comm-test-tip")

4
src/Jobs/Handler/SendCourseCommunication.hs
View File

@ -49,12 +49,12 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
dispatchJobSendFirmCommunication :: Either UserEmail UserId
-> Set Address
-> Maybe CompanyShorthand
-> Companies
-> UserId
-> UUID
-> CommunicationContent
-> JobHandler UniWorX
dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
-- (sender,mbComp) <- runDB $ (,)
-- <$> getJust jSender
-- <*> ifMaybeM jCompany Nothing get

2
src/Jobs/Types.hs
View File

@ -76,7 +76,7 @@ data Job
}
| JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId
, jAllRecipientAddresses :: Set Address
, jCompany :: Maybe CompanyShorthand
, jCompanies :: Companies
, jSender :: UserId
, jMailObjectUUID :: UUID
, jMailContent :: CommunicationContent

1
src/Model/Types/Common.hs
View File

@ -43,6 +43,7 @@ type SchoolShorthand = CI Text
type CompanyName = CI Text
type CompanyShorthand = CI Text
type Companies = [CI Text]
type CourseName = CI Text
type CourseShorthand = CI Text

2
templates/widgets/communication/recipientLayout.hamlet
View File

@ -35,6 +35,8 @@ $if not (null activeCategories)
_{MsgFirmSupervisorOf fsh}
$of RecipientGroup (RGFirmEmployees fsh)
_{MsgFirmEmployeeOf fsh}
$of RecipientGroup (RGFirmIndependent)
_{MsgFirmSupervisorIndependent}
$if hasContent category
<fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>