From 65cdc8ddfef19eb3a5578c536575f91ba9717a13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 16:55:14 +0100 Subject: [PATCH] fix(firm): firm messaging now works fine --- .../uniworx/categories/firm/de-de-formal.msg | 1 + messages/uniworx/categories/firm/en-eu.msg | 1 + routes | 2 +- src/Foundation/Navigation.hs | 2 +- src/Handler/Firm.hs | 110 ++++++----- src/Handler/Utils/Communication.hs | 187 +++++++++--------- src/Jobs/Handler/SendCourseCommunication.hs | 4 +- src/Jobs/Types.hs | 2 +- src/Model/Types/Common.hs | 3 +- .../communication/recipientLayout.hamlet | 2 + 10 files changed, 160 insertions(+), 154 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index c50120e92..3e27e0ba5 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -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} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 3e24de5c5..ddef25a86 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -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 \ No newline at end of file diff --git a/routes b/routes index 931c52909..d341734ac 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 0c8cbd1a2..b029cc0ee 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 2c428eb7e..bfcb14794 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -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,71 +792,77 @@ 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 - (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 - ) - -} - - 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 +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 - )) - - 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 + 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)) - 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.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 - ) - return usr + 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 + E.&&. (if sORe + then -- supervisors only + E.exists $ 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 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: diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 28473dfc1..333d088cb 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -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,103 +139,100 @@ 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 + 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 display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap - let chosenRecipients' = Map.fromList $ - [ ( (BoundedPosition $ RecipientGroup g, pos) - , (Right recp, recp `elem` map entityKey chosenRecipients) - ) - | (g, recps) <- suggestedRecipients - , (pos, recp) <- zip [0..] $ map entityKey recps - ] ++ - [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) - ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) - ] - activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom + chosenRecipients' = Map.fromList $ + [ ( (BoundedPosition $ RecipientGroup g, pos) + , (Right recp, recp `elem` map entityKey chosenRecipients) + ) + | (g, recps) <- suggestedRecipients + , (pos, recp) <- zip [0..] $ map entityKey recps + ] ++ + [ ( (BoundedPosition RecipientCustom, pos) + , (Right recp, True) + ) + | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + ] + activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom - let 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 - (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing - let - addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails - return (addRes', $(widgetFile "widgets/communication/recipientAdd")) - miAdd _ _ _ _ _ = Nothing - miCell _ (Left (CI.original -> email)) initRes nudge csrf = do - (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do - (tickRes, tickView) <- if - | fmap entityKey cUser == Just uid - -> mforced checkBoxField ("" & addName (nudge "tick")) True - | otherwise - -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientName")) - miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True - miAllowAdd _ _ _ = False - miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) - miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute - miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength - -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) - -> Map (BoundedPosition RecipientCategory, ListPosition) Widget - -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) - -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget - -> Widget - miLayout liveliness cState cellWdgts _delButtons addWdgts = do - checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState - checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c - hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts - categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness - rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget - rgTutorialParticipantsCaption cID = do - tutId <- decrypt cID - Tutorial{..} <- liftHandler . runDBRead $ get404 tutId - i18n $ MsgRGTutorialParticipants tutorialName - rgExamRegisteredCaption :: CryptoUUIDExam -> Widget - rgExamRegisteredCaption cID = do - eId <- decrypt cID - Exam{..} <- liftHandler . runDBRead $ get404 eId - i18n $ MsgRGExamRegistered examName - rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget - rgSheetSubmittorCaption cID = do - sId <- decrypt cID - Sheet{..} <- liftHandler . runDBRead $ get404 sId - i18n $ MsgRGSheetSubmittor sheetName - $(widgetFile "widgets/communication/recipientLayout") - miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) - -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos - miDelete _ _ = mzero - miIdent :: Text - miIdent = "recipients" - postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) - postProcess = Set.fromList . map fst . filter snd . Map.elems + 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 + (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing + let + addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails + return (addRes', $(widgetFile "widgets/communication/recipientAdd")) + miAdd _ _ _ _ _ = Nothing + miCell _ (Left (CI.original -> email)) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do + (tickRes, tickView) <- if + | fmap entityKey cUser == Just uid + -> mforced checkBoxField ("" & addName (nudge "tick")) True + | otherwise + -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False + miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) + miAddEmpty _ _ _ = Set.empty + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength + -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) + -> Map (BoundedPosition RecipientCategory, ListPosition) Widget + -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) + -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget + -> Widget + miLayout liveliness cState cellWdgts _delButtons addWdgts = do + checkedIdentBase <- newIdent + let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState + checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c + hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts + categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness + rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget + rgTutorialParticipantsCaption cID = do + tutId <- decrypt cID + Tutorial{..} <- liftHandler . runDBRead $ get404 tutId + i18n $ MsgRGTutorialParticipants tutorialName + rgExamRegisteredCaption :: CryptoUUIDExam -> Widget + rgExamRegisteredCaption cID = do + eId <- decrypt cID + Exam{..} <- liftHandler . runDBRead $ get404 eId + i18n $ MsgRGExamRegistered examName + rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget + rgSheetSubmittorCaption cID = do + sId <- decrypt cID + Sheet{..} <- liftHandler . runDBRead $ get404 sId + i18n $ MsgRGSheetSubmittor sheetName + $(widgetFile "widgets/communication/recipientLayout") + miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) + -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos + miDelete _ _ = mzero + miIdent :: Text + miIdent = "recipients" + postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) + postProcess = Set.fromList . map fst . filter snd . Map.elems 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 @@ -255,8 +252,7 @@ commR CommunicationRoute{..} = do <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> 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") diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index fa4fbcb69..4edaa2d4d 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6c665adb4..78b4fe50b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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 diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 836d2741e..df9bc1a79 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -42,7 +42,8 @@ type SchoolName = CI Text type SchoolShorthand = CI Text type CompanyName = CI Text -type CompanyShorthand = CI Text +type CompanyShorthand = CI Text +type Companies = [CI Text] type CourseName = CI Text type CourseShorthand = CI Text diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index 9dc2beea0..cd5546277 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -35,6 +35,8 @@ $if not (null activeCategories) _{MsgFirmSupervisorOf fsh} $of RecipientGroup (RGFirmEmployees fsh) _{MsgFirmEmployeeOf fsh} + $of RecipientGroup (RGFirmIndependent) + _{MsgFirmSupervisorIndependent} $if hasContent category