+ ^{widgetMailPrefPin rcvr} # + ^{updateAutomatic auto} # +
+ #{mailtoHtml eml} + |] + (True, (Just postal, auto), _) -> do -- postal + return [whamlet| +
+ ^{widgetMailPrefPin rcvr} # + ^{updateAutomatic auto} +
+ #{postal}
+ |]
+ _ -> return $ msg2widget MsgNoContactAddress
+ , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view $ resultReceiver . _entityKey -> ruid) -> sqlCell
+ (maybeMonoid <$> wgtCompanies ruid) -- TODO: user wgtCompanies' to check mismatch in companies
+ -- , colUserLetterEmailPin
+ -- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute
+ -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+ -- , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+ -- let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+ -- in if isReroute
+ -- then iconCell IconReroute <> blankCell <> cellMailPrefPin (row ^. resultUser)
+ -- else mempty
+ , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+ , sortable (Just "reason") (i18nCell MsgTableReason) $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorReason . _Just -> mr) -> maybeCell mr textCell
+ ]
+ validator = def -- & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
+ dbtSorting = Map.fromList
+ [ sortUserNameLink queryReceiver
+ -- , sortUserLetterEmailPin queryReceiver
+ , sortUserEmail queryReceiver
+ , ("user-company" , SortColumn (\row -> E.subSelect $ do
+ (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
+ E.where_ $ usrCmp E.^. UserCompanyUser E.==. queryReceiver row E.^. UserId
+ E.orderBy [E.asc $ cmp E.^. CompanyName]
+ return (cmp E.^. CompanyName)
+ ))
+ -- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
+ -- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
+ -- -- , singletonMap "reroute" $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) -> mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
+ -- , singletonMap "reroute" $ SortColumns $ \row ->
+ -- [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
+ -- , SomeExprValue $ queryUser row E.^. UserPrefersPostal
+ -- ]
+ , ("cshort", SortColumn $ queryReceiverSupervisor >>> (E.?. UserSupervisorCompany))
+ , ("reason", SortColumn $ queryReceiverSupervisor >>> (E.?. UserSupervisorReason))
+ ]
+ dbtFilter = mconcat
+ [ singletonMap & uncurry $ fltrUserNameEmail queryReceiver
+ ]
+ dbtFilterUI = mempty
+ dbtParams = def
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ dbtExtraReps = []
+
getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
@@ -1356,3 +1453,52 @@ postLangR = do
addMessage Success . toHtml $ mr MsgLanguageChanged
redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer
+
+
+getUserRecipientsR :: CryptoUUIDUser -> Handler Html
+getUserRecipientsR uuid = do
+ uid <- decrypt uuid
+ (usr, receivers, usrReceives) <- updateReceivers uid -- if this is two due to the AVS queries, try Handler.Utils.getReceivers instead
+ mrtbl <- case receivers of
+ [] -> return Nothing -- no receivers
+ [_] | usrReceives -> return Nothing -- only user receives for themself
+ _ -> Just <$> runDB (mkReceiversTable uid receivers)
+ let heading = MsgUserRecipientsTitle $ usr ^. _userDisplayName
+ usrWgt = userWidget usr
+ hasPwd = isJust $ usr ^. _userPinPassword
+ siteLayoutMsg heading $ do
+ setTitleI heading -- TODO: translate to i18nWidgetFile
+ [whamlet|
+
+ Benachrichtigungen für ^{usrWgt} ^{widgetMailPrefPin usr} #
+ $if usrReceives
+ gehen #
+ $maybe _ <- mrtbl
+ ebenfalls an die unten aufgeführten Personen:
+ $nothing
+ nur an diese Person selbst.
+ $else
+ $maybe _ <- mrtbl
+ gehen tatsächlich nur an die unten aufgeführten Personen:
+ $nothing
+ werden momentan an niemanden zugestellt!
+ $maybe tbl <- mrtbl
+
+ ^{tbl}
+
+
^{c}
|]
- return $ toMaybe (notNull topCmp) resWgt
+ return $ toMaybe (notNull topCmp) (resWgt, topIds)
where
- procCmp _ [] = (0, [], [])
+ procCmp _ [] = (0, [], [], [])
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
let isTop = cmpPrio >= maxPri
cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
- (accPri,accTop,accRem) = procCmp maxPri cs
- in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
+ (accPri,accTop,accRem,accTopId) = procCmp maxPri cs
+ in ( max cmpPrio accPri
+ , bool accTop (cmpWgt : accTop) isTop -- lazy evaluation after repmin example, don't factor out the bool!
+ , bool (cmpWgt : accRem) accRem isTop
+ , bool accTopId (cmpSh : accTopId) isTop
+ )
type AnySuperReason = Either SupervisorReason (Maybe Text)
diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs
index 652e58936..a4d0480f7 100644
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@@ -32,6 +32,9 @@ spacerCell = cell [whamlet| |]
semicolonCell :: IsDBTable m a => DBCell m a
semicolonCell = cell [whamlet|; |]
+blankCell :: IsDBTable m a => DBCell m a
+blankCell = textCell " "
+
-- | Contribute to DBResult. BEWARE: only shown cells are executed; pagination makes tellCell useless for rowcounts; instead use dbtProj for computations on all rows regardless of pagination
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
tellCell = flip mappend . writerCell . tell
@@ -116,7 +119,7 @@ iconBoolCell :: IsDBTable m a => Bool -> DBCell m a
iconBoolCell = cell . toWidget . boolSymbol
ifIconCell :: IsDBTable m a => Bool -> Icon -> DBCell m a
-ifIconCell True = iconCell
+ifIconCell True = iconFixedCell . icon
ifIconCell False = const iconSpacerCell
addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
@@ -218,12 +221,22 @@ emailCell :: IsDBTable m a => CI Text -> DBCell m a
emailCell email = cell $(widgetFile "widgets/link-email")
where linkText= toWgt email
-cellMailPrefPin :: (IsDBTable m a, HasUser u) => u -> DBCell m a
+
+cellMailPrefPin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
cellMailPrefPin usr =
- iconFixedCell (iconLetterOrEmail prefPost) <> ifIconCell (not prefPost && hasPin) IconPinProtect
- where
- prefPost = usr ^. _userPrefersPostal
- hasPin = isJust (usr ^. _userPinPassword)
+ let userEntity = usr ^. hasEntityUser
+ uid = userEntity ^. _entityKey
+ rwgt = do
+ uuid <- liftHandler $ encrypt uid
+ modal (widgetMailPrefPin userEntity) (Left $ SomeRoute $ UserRecipientsR uuid)
+ in cell rwgt -- addIconFixedWidth
+
+-- cellMailPrefPin :: (IsDBTable m a, HasUser u) => u -> DBCell m a
+-- cellMailPrefPin usr =
+-- iconFixedCell (iconLetterOrEmail prefPost) <> blankCell <> ifIconCell (not prefPost && hasPin) IconPinProtect
+-- where
+-- prefPost = usr ^. _userPrefersPostal
+-- hasPin = isJust (usr ^. _userPinPassword)
cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c
cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname)
diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs
index 54dbd304e..3f10b313e 100644
--- a/src/Handler/Utils/Table/Columns.hs
+++ b/src/Handler/Utils/Table/Columns.hs
@@ -495,7 +495,7 @@ fltrUserEmailUI mPrev =
-- | Icon column showing whether the user prefers emails, and if so, whether a pdf password is set
-colUserLetterEmailPin :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
+colUserLetterEmailPin :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
colUserLetterEmailPin = sortable (Just "user-mail-pref-pin") (i18nCell MsgPrefersPostal) cellMailPrefPin
sortUserLetterEmailPin :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 6e62c4aa6..7fbb3ee0d 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -91,7 +91,8 @@ getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
MaybeT $ pure $ prj company
--- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
+-- | Compute actual address for user; returning True for Postal preference, as well as address (user or company) and primary e-mail
+-- result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
getPostalPreferenceAndAddress usr = do
pa <- getPostalAddress usr
diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs
index fe93cc9c8..c19ae4393 100644
--- a/src/Handler/Utils/Widgets.hs
+++ b/src/Handler/Utils/Widgets.hs
@@ -172,6 +172,15 @@ companyWidget isPrimary (csh, cname, isSupervisor)
| isSupervisor = text2markup (corg <> " ")
| otherwise = text2markup corg
+widgetMailPrefPin :: HasUser u => u -> Widget -- TODO: move to appropriate module
+widgetMailPrefPin usr = if not prefPost && hasPin
+ then [whamlet|^{modWgt} ^{pinWgt}|]
+ else modWgt
+ where
+ prefPost :: Bool = usr ^. _userPrefersPostal
+ hasPin :: Bool = isJust (usr ^. _userPinPassword)
+ modWgt :: Widget = toWidget $ iconLetterOrEmail prefPost
+ pinWgt :: Widget = toWidget iconPinProtect
---------------------
-- Status Tooltips --
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 676ced98a..b4bfb264d 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -645,13 +645,13 @@ fillDb = do
I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course.
|]
}
- fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True (Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text)) (Just "fraport@fraport.de")
- fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True (Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text)) Nothing
- nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False (Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text)) (Just "badguy@nice.com")
- ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com"
- bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing
- _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing
- randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing | n <- [1001..2002]
+ fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True (Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text)) (Just "fraport@fraport.de") False
+ fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True (Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text)) Nothing True
+ nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False (Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text)) (Just "badguy@nice.com") False
+ ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing(Just "gcs@gcs.com") True
+ bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing False
+ _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing True
+ randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing True | n <- [1001..2002]
, let neven = even n
, let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
, let rcShort = CI.mk $ "RC" <> tshow n
+ Hinweise:
+ Mit welchem Passwort PDF Anhänge geschützt werden, hängt von der Nachricht ab. #
+
+ Zum Beispiel werden Pin Briefe für ablaufende Qualifikationen #
+ $if hasPwd
+ mit dem Passwort von ^{usrWgt} geschützt. #
+ $else
+ nicht geschützt, da kein Pin Passwort gesetzt ist. #
+
+ Für andere Benachrichtigungen wird meist das Passwort des tatsächlichen Empfängers gewählt, sofern eins gesetzt wurde.
+
+ Die Voreinstellung für das PDF Passwort ist die Hauptausweisnummer, inklusive Punkt.
+ |]
+
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 76e1a2507..aafdacd02 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -132,6 +132,7 @@ postUsersR = do
, sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
, colUserEmail
+ , colUserLetterEmailPin
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
, flip foldMap universeF $ \function ->
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
@@ -223,6 +224,7 @@ postUsersR = do
) | function <- universeF
] ++
[ sortUserEmail id
+ , sortUserLetterEmailPin id
, ( "name"
, SortColumn (E.^. UserSurname)
)
diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs
index 792119e63..21f9a4ef8 100644
--- a/src/Handler/Utils/Company.hs
+++ b/src/Handler/Utils/Company.hs
@@ -38,14 +38,18 @@ company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey
wgtCompanies :: UserId -> DB (Maybe Widget)
-wgtCompanies = \uid -> do
+wgtCompanies = (fst <<$>>) . wgtCompanies'
+
+-- | Given a UserId, create widgets showing top-companies (with internal link) and associated companies (unlinked)
+wgtCompanies' :: UserId -> DB (Maybe (Widget, [CompanyShorthand]))
+wgtCompanies' uid = do
companies <- E.select $ do
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
`E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
- let (mPri, topCmp, otherCmp) = procCmp mPri companies
+ let (mPri, topCmp, otherCmp, topIds) = procCmp mPri companies
resWgt =
[whamlet|
$forall c <- topCmp
@@ -55,14 +59,18 @@ wgtCompanies = \uid -> do