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 FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
FilterFirmPostalAddress: Postalische Firmenadresse vorhanden FilterFirmPostalAddress: Postalische Firmenadresse vorhanden
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} 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 FilterForeignSupervisor: Has company-external supervisors
FilterFirmPostalAddress: Postal company addresse known FilterFirmPostalAddress: Postal company addresse known
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
FirmSupervisorIndependent: Independent supervisors
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users

2
routes
View File

@ -114,7 +114,7 @@
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
/firms FirmAllR GET POST !supervisor /firms FirmAllR GET POST !supervisor
/firms/comm FirmsCommR GET POST /firms/comm/+Companies FirmsCommR GET POST
/firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand FirmR GET POST
/firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST
/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /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 ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing 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 FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh

110
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 (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
formResult firmRes $ \case formResult firmRes $ \case
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" (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 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) (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 return $ usr E.^. UserId
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] 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 siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms setTitleI MsgMenuFirms
$(i18nWidgetFile "firm-all") $(i18nWidgetFile "firm-all")
@ -792,71 +792,77 @@ postFirmSupersR fsh = do
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
getFirmCommR = postFirmCommR 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 getFirmsCommR = postFirmsCommR
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR)
handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
handleFirmCommR ultDest mbFsh = do handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."]
let decryptUserId :: CryptoUUIDUser -> Handler UserId handleFirmCommR ultDest cs = do
decryptUserId = decrypt let csKey = CompanyKey <$> cs
-- get employees of chosen companies
mbCid = CompanyKey <$> mbFsh empys <- E.unValue <<$>> runDB (E.select $ do
{-
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
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) (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 return $ emp E.^. UserId
)) )
-- get supervisors of employees
cmpys <- E.unValue <<$>> runDB (E.select $ do 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 cmpy <- E.from $ E.table @Company
E.where_ $ E.exists $ do E.where_ $ E.exists $ do
usrCmpy <- E.from $ E.table @UserCompany usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs
return $ cmpy E.^.CompanyId return $ cmpy E.^.CompanyId
) )
let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) let
queryCmpy sORe acid = do queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) queryLoners = do
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid spr <- E.from $ E.table @User
E.&&. (if sORe E.where_ $ spr E.^. UserId `E.in_` E.valList empys
then -- supervisors only E.&&. E.notExists (do
E.exists $ do sprCmp <- E.from $ E.table @UserCompany
usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId )
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys return $ spr
else -- selected employees for this company only
usr E.^. UserId `E.in_` E.valList empys queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
) queryCmpy sORe acid = do
return usr (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 commR CommunicationRoute
{ crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c; _ -> MsgFirmsNotification }
, crUltDest = ultDest , crUltDest = ultDest
, crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crTestJobs = crTestFirmCommunication mbFsh -- :: 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)))]
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid] (RGFirmIndependent, queryLoners) :
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ]
} }
{- Auswahlbox für Mitteilung: {- Auswahlbox für Mitteilung:

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

@ -32,7 +32,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect
| RGTutorialParticipants CryptoUUIDTutorial | RGTutorialParticipants CryptoUUIDTutorial
| RGExamRegistered CryptoUUIDExam | RGExamRegistered CryptoUUIDExam
| RGSheetSubmittor CryptoUUIDSheet | RGSheetSubmittor CryptoUUIDSheet
| RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
instance LowerBounded RecipientGroup where instance LowerBounded RecipientGroup where
@ -110,8 +110,8 @@ crTestJobsCourseCommunication jCourse comm = do
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crJobsFirmCommunication jCompany Communication{..} = do crJobsFirmCommunication jCompanies Communication{..} = do
jSender <- requireAuthId jSender <- requireAuthId
let jMailContent = cContent let jMailContent = cContent
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
@ -122,12 +122,12 @@ crJobsFirmCommunication jCompany Communication{..} = do
forM_ allRecipients $ \jRecipientEmail -> forM_ allRecipients $ \jRecipientEmail ->
yield JobSendFirmCommunication{..} yield JobSendFirmCommunication{..}
crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
crTestFirmCommunication jCompany comm = do crTestFirmCommunication jCompanies comm = do
jSender <- requireAuthId jSender <- requireAuthId
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) 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 uid <- decrypt cID
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
getEntity uid getEntity uid
cUser <- maybeAuth 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 MsgRenderer mr <- getMsgRenderer
mbCurrentRoute <- getCurrentRoute 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 let
lookupUser :: UserId -> (UserDisplayName,UserSurname) lookupUser :: UserId -> (UserDisplayName,UserSurname)
lookupUser = lookupUser =
let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients 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) usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname)
in usrNames . flip Map.lookup usrMap in usrNames . flip Map.lookup usrMap
let chosenRecipients' = Map.fromList $ chosenRecipients' = Map.fromList $
[ ( (BoundedPosition $ RecipientGroup g, pos) [ ( (BoundedPosition $ RecipientGroup g, pos)
, (Right recp, recp `elem` map entityKey chosenRecipients) , (Right recp, recp `elem` map entityKey chosenRecipients)
) )
| (g, recps) <- suggestedRecipients | (g, recps) <- suggestedRecipients
, (pos, recp) <- zip [0..] $ map entityKey recps , (pos, recp) <- zip [0..] $ map entityKey recps
] ++ ] ++
[ ( (BoundedPosition RecipientCustom, pos) [ ( (BoundedPosition RecipientCustom, pos)
, (Right recp, True) , (Right recp, True)
) )
| (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) | (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 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') recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where where
miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do 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 (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
let 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 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")) return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
miAdd _ _ _ _ _ = Nothing miAdd _ _ _ _ _ = Nothing
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do
(tickRes, tickView) <- if (tickRes, tickView) <- if
| fmap entityKey cUser == Just uid | fmap entityKey cUser == Just uid
-> mforced checkBoxField ("" & addName (nudge "tick")) True -> mforced checkBoxField ("" & addName (nudge "tick")) True
| otherwise | otherwise
-> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientName")) return (tickRes, $(widgetFile "widgets/communication/recipientName"))
miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True
miAllowAdd _ _ _ = False miAllowAdd _ _ _ = False
miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0)
miAddEmpty _ _ _ = Set.empty miAddEmpty _ _ _ = Set.empty
miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength
-> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool)
-> Map (BoundedPosition RecipientCategory, ListPosition) Widget -> Map (BoundedPosition RecipientCategory, ListPosition) Widget
-> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX)
-> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget
-> Widget -> Widget
miLayout liveliness cState cellWdgts _delButtons addWdgts = do miLayout liveliness cState cellWdgts _delButtons addWdgts = do
checkedIdentBase <- newIdent 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 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 checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts
categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness
rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget
rgTutorialParticipantsCaption cID = do rgTutorialParticipantsCaption cID = do
tutId <- decrypt cID tutId <- decrypt cID
Tutorial{..} <- liftHandler . runDBRead $ get404 tutId Tutorial{..} <- liftHandler . runDBRead $ get404 tutId
i18n $ MsgRGTutorialParticipants tutorialName i18n $ MsgRGTutorialParticipants tutorialName
rgExamRegisteredCaption :: CryptoUUIDExam -> Widget rgExamRegisteredCaption :: CryptoUUIDExam -> Widget
rgExamRegisteredCaption cID = do rgExamRegisteredCaption cID = do
eId <- decrypt cID eId <- decrypt cID
Exam{..} <- liftHandler . runDBRead $ get404 eId Exam{..} <- liftHandler . runDBRead $ get404 eId
i18n $ MsgRGExamRegistered examName i18n $ MsgRGExamRegistered examName
rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget
rgSheetSubmittorCaption cID = do rgSheetSubmittorCaption cID = do
sId <- decrypt cID sId <- decrypt cID
Sheet{..} <- liftHandler . runDBRead $ get404 sId Sheet{..} <- liftHandler . runDBRead $ get404 sId
i18n $ MsgRGSheetSubmittor sheetName i18n $ MsgRGSheetSubmittor sheetName
$(widgetFile "widgets/communication/recipientLayout") $(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 :: 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 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 miDelete _ _ = mzero
miIdent :: Text miIdent :: Text
miIdent = "recipients" miIdent = "recipients"
postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
postProcess = Set.fromList . map fst . filter snd . Map.elems postProcess = Set.fromList . map fst . filter snd . Map.elems
recipientsListMsg <- messageI Info MsgCommRecipientsList recipientsListMsg <- messageI Info MsgCommRecipientsList
$logWarnS "COMM" "Communication handler some definitions done"
attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
let attachmentField = genericFileField $ return FileField let attachmentField = genericFileField $ return FileField
{ fieldIdent = Nothing { fieldIdent = Nothing
@ -246,7 +243,7 @@ commR CommunicationRoute{..} = do
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
, fieldAllEmptyOk = True , fieldAllEmptyOk = True
} }
$logWarnS "COMM" "Communication handler some parameters done" -- SEEN
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
<$> recipientAForm <$> recipientAForm
<* aformMessage recipientsListMsg <* aformMessage recipientsListMsg
@ -255,8 +252,7 @@ commR CommunicationRoute{..} = do
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
(fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
) )
$logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE
formResult commRes $ \case formResult commRes $ \case
(comm, BtnCommunicationSend) -> do (comm, BtnCommunicationSend) -> do
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
@ -265,14 +261,13 @@ commR CommunicationRoute{..} = do
(comm, BtnCommunicationTest) -> do (comm, BtnCommunicationTest) -> do
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs
addMessageI Info MsgCommTestSuccess addMessageI Info MsgCommTestSuccess
$logWarnS "COMM" "Communication handler form result done"
let formWdgt = wrapForm commWdgt def let formWdgt = wrapForm commWdgt def
{ formMethod = POST { formMethod = POST
, formAction = SomeRoute <$> mbCurrentRoute , formAction = SomeRoute <$> mbCurrentRoute
, formEncoding = commEncoding , formEncoding = commEncoding
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
$logWarnS "COMM" "Communication handler finished"
siteLayoutMsg crHeading $ do siteLayoutMsg crHeading $ do
setTitleI crHeading setTitleI crHeading
let commTestTip = $(i18nWidgetFile "comm-test-tip") 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 dispatchJobSendFirmCommunication :: Either UserEmail UserId
-> Set Address -> Set Address
-> Maybe CompanyShorthand -> Companies
-> UserId -> UserId
-> UUID -> UUID
-> CommunicationContent -> CommunicationContent
-> JobHandler UniWorX -> JobHandler UniWorX
dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
-- (sender,mbComp) <- runDB $ (,) -- (sender,mbComp) <- runDB $ (,)
-- <$> getJust jSender -- <$> getJust jSender
-- <*> ifMaybeM jCompany Nothing get -- <*> ifMaybeM jCompany Nothing get

2
src/Jobs/Types.hs
View File

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

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

@ -42,7 +42,8 @@ type SchoolName = CI Text
type SchoolShorthand = CI Text type SchoolShorthand = CI Text
type CompanyName = CI Text type CompanyName = CI Text
type CompanyShorthand = CI Text type CompanyShorthand = CI Text
type Companies = [CI Text]
type CourseName = CI Text type CourseName = CI Text
type CourseShorthand = CI Text type CourseShorthand = CI Text

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

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