fix(firm): firm messaging now works fine
This commit is contained in:
parent
42ff02d27e
commit
65cdc8ddfe
@ -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}
|
||||
@ -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
2
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user