Merge branch 'fradrive/company'

messages/uniworx/categories/firm/de-de-formal.msg

@@ -3,16 +3,29 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 FirmAssociates: Firmenangehörige
+FirmContact: Firmenkontakt
+FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt.
 FirmEmail: Allgemeine Email
 FirmAddress: Postanschrift
 FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
-FirmAllActNotify: Mitteilung versenden
+FirmAction: Firmenweite Aktion
-FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
+FirmActionInfo: Betrifft alle Firmenangehörigen.
-FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
+FirmActNotify: Mitteilung versenden
-FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
+FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
+FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
+FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
+FirmActAddSupersvisors: Ansprechpartner hinzufügen
+FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
+FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
+RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
+FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern
+FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
+FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
+FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen
 FirmUserActNotify: Mitteilung versenden
 FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
 FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
+FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
 FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
 FirmSuperActNotify: Mitteilung versenden
 FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen
@@ -29,12 +42,9 @@ FilterFirmExtern: Externe Firma
 FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
 FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
 FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
-NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus.
+NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
 TableIsDefaultSupervisor: Standardansprechpartner
 TableIsDefaultReroute: Standardumleitung
-FormReqPostal: Benachrichtigungseinstellung
+FormFieldPostal: Benachrichtigungseinstellung
-FormReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
+FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
-ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
-ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
-RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
 FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert

messages/uniworx/categories/firm/en-eu.msg

@@ -3,16 +3,29 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 FirmAssociates: Company associated users
+FirmContact: Company Contact
+FirmNoContact: No general contact information known.
 FirmEmail: General company email
 FirmAddress: Postal address
 FirmDefaultPreferenceInfo: Default setting for new company associates only
-FirmAllActNotify: Send message
+FirmAction: Companywide action
-FirmAllActResetSupervision: Reset supervisors for all company associates
+FirmActionInfo: Affects alle company associates.
+FirmActNotify: Send message
+FirmActResetSupervision: Reset supervisors for all company associates
+FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
+FirmActResetMutualSupervision: Supervisors supervise each other
+FirmActAddSupersvisors: Add supervisors
+FirmActAddSupersEmpty: No supervisors added
+FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
+RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)}
+FirmActChangeContactUser: Change contact data for company associates
+FirmActChangeContactFirm: Change company contact data
+FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
+FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only
 FirmUserActNotify: Send message
-FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates?
-FirmAllActResetMutualSupervision: Supervisors supervise each other
 FirmUserActResetSupervision: Reset supervisors to company default
 FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
+FirmUserActChangeContact: Change contact data for selected company associates
 FirmUserActMkSuper: Mark as company supervisor
 FirmSuperActNotify: Send message
 FirmSuperActRMSuperDef: Remove as default supervisor
@@ -32,9 +45,6 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
 NoCompanySelected: Select at least one company, please.
 TableIsDefaultSupervisor: Default supervisor
 TableIsDefaultReroute: Default reroute
-FormReqPostal: Notification type
+FormFieldPostal: Notification type
-FormReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
+FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
-ASReqEmpty: No supervisors added
-ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
-RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)}
 FirmUserChanges n: Notification settings changed for #{n} company associates

models/users.model

@@ -34,7 +34,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     timeFormat     DateTimeFormat "default='%R'"             -- preferred Time-only display format for user; user-defined
     downloadFiles  Bool default=false           -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
     languages      Languages Maybe          -- Preferred language; user-defined
-    notificationSettings NotificationSettings  "default='{}'::jsonb"   -- Bit-array for which events email notifications are requested by user; user-defined
+    notificationSettings NotificationSettings  "default='{}'::jsonb"   -- Bit-array for which events email notifications are requested by user; user-defined; missing fields in json object will be parsed to default trigger
     warningDays    NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
     csvOptions     CsvOptions "default='{}'::jsonb"
     sex            Sex Maybe  -- currently ignored

routes

@@ -115,9 +115,9 @@
 
 /firms                          FirmAllR            GET POST		!supervisor
 /firms/comm/+Companies          FirmsCommR          GET POST
-/firm/#CompanyShorthand         FirmR               GET POST
+/firm/#CompanyShorthand/debug   FirmR               GET POST
 /firm/#CompanyShorthand/comm    FirmCommR						GET POST
-/firm/#CompanyShorthand/users   FirmUsersR          GET POST    !supervisor
+/firm/#CompanyShorthand         FirmUsersR          GET POST    !supervisor
 /firm/#CompanyShorthand/supers  FirmSupersR         GET POST    !supervisor
 
 /exam-office               ExamOfficeR                         !exam-office:

shell.nix

@@ -223,7 +223,7 @@ let
     fi
   '';
 
-  killallUni2work = pkgs.writeScriptBin "killall-uni2work" ''
+  killallUni2work = pkgs.writeScriptBin "killuni2work" ''
     #!${pkgs.zsh}/bin/zsh
 
     set -o pipefail

src/Handler/Firm.hs

@@ -2,7 +2,7 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-}      -- TODO: remove me, for debugging only
+{-# OPTIONS -Wno-unused-top-binds #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
 {-# LANGUAGE TypeApplications #-}
 
@@ -32,7 +32,7 @@ import qualified Data.CaseInsensitive as CI
 import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as EL (from, on)
+import qualified Database.Esqueleto.Legacy as EL (on)
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
@@ -42,18 +42,186 @@ import Database.Esqueleto.Utils.TH
 single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
-decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
+-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
-decryptUser = decrypt 
+-- decryptUser = decrypt
 
 encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
 encryptUser = encrypt
 
+postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
+postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged
+
+---------------------------------
+-- General firm affecting actions
+
+data FirmAction = FirmActNotify
+                | FirmActResetSupervision
+                | FirmActAddSupersvisors
+                | FirmActChangeContactFirm
+                | FirmActChangeContactUser
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''FirmAction $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''FirmAction id
+
+data FirmActionData = FirmActNotifyData
+                    | FirmActResetSupervisionData
+                        { firmActResetKeepOldSupers       :: Maybe Bool
+                        , firmActResetMutualSupervision   :: Maybe Bool
+                        }
+                    | FirmActAddSupersvisorsData
+                        { firmActAddSupervisorIds         :: Set Text
+                        , firmActAddSupervisorReroute     :: Bool
+                        , firmActAddSupervisorPostal      :: Maybe Bool
+                        }
+                    | FirmActChangeContactFirmData
+                        { firmActCCFPostalAddr            :: Maybe StoredMarkup
+                        , firmActCCFEmail                 :: Maybe UserEmail
+                        , firmActCCFPostalPref            :: Maybe Bool
+                        }
+                    | FirmActChangeContactUserData
+                        { firmActCCUPostalAddr            :: Maybe StoredMarkup
+                        , firmActCCUPostalPref            :: Maybe Bool
+                        }
+  deriving (Eq, Ord, Read, Show, Generic)
+
+firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
+firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
+  where
+    mkAct True  FirmActNotify           = singletonMap FirmActNotify           $ pure FirmActNotifyData
+    mkAct _     FirmActResetSupervision = singletonMap FirmActResetSupervision $      FirmActResetSupervisionData
+                  <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
+                  <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
+    mkAct _     FirmActAddSupersvisors   = singletonMap FirmActAddSupersvisors   $ FirmActAddSupersvisorsData
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute )                                                            (Just True)
+                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
+    mkAct _     FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
+                  <$> aopt htmlField                        (fslI MsgPostAddress   & setTooltip MsgPostAddressTip)                Nothing
+                  <*> aopt (emailField & cfStrip & cfCI)    (fslI MsgUserDisplayEmail)                                            Nothing
+                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)          Nothing
+                  <*  aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
+    mkAct _     FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
+                  <$> aopt htmlField                        (fslI MsgPostAddress    & setTooltip MsgPostAddressTip)               Nothing
+                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip)         Nothing
+    mkAct _  _ = mempty
+
+firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData
+firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
+
+makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
+makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts
+
+firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
+firmActionHandler route = flip formResult faHandler
+  where
+    faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
+    faHandler (FirmActResetSupervisionData{..}, fids) = do
+      runDB $ do
+        delSupers <- if firmActResetKeepOldSupers == Just False
+          then E.deleteCount $ do
+                spr <- E.from $ E.table @UserSupervisor
+                E.where_ $ E.exists $ do
+                  usr <- E.from $ E.table @UserCompany
+                  E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
+                      E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+          else return 0
+        newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids
+        addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
+      reloadKeepGetParams route -- reload to reflect changes
+
+    faHandler (FirmActNotifyData, 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 fids
+        return $ usr E.^. UserId
+      cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
+      redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
+
+    faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
+      avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
+      let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
+          usersFound = mapMaybe snd usersFound'
+      unless (null usersNotFound) $
+        let msgContent = [whamlet|
+              $newline never
+              <ul>
+                $forall (usr,_) <- usersNotFound
+                  <li>#{usr}
+              |]
+        in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
+      when (null usersFound) $ do
+        addMessageI Warning MsgFirmActAddSupersEmpty
+        reloadKeepGetParams route
+      runDB $ do
+        putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
+        whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
+          updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
+        addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
+      redirect route
+
+    faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) =
+      let changes = catMaybes
+            [ (CompanyPostAddress   =.) . Just <$> canonical firmActCCFPostalAddr
+            , (CompanyEmail         =.) . Just <$> canonical firmActCCFEmail
+            , (CompanyPrefersPostal =.)        <$>           firmActCCFPostalPref
+            ]
+      in unless (null changes) $ do
+        runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes
+        addMessageI Success MsgFirmActChangeContactFirmResult
+        reloadKeepGetParams route
+
+    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
+      let changes = catMaybes
+            [ (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
+            , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
+            ]
+      in unless (null changes) $ do
+        nrChanged <- runDB $ E.updateCount $ \usr -> do
+          E.set usr changes
+          E.where_ $ E.exists $ do
+            usrCmpy <- E.from $ E.table @UserCompany
+            E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
+                E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
+        addMessageI Success $ MsgFirmUserChanges nrChanged
+        reloadKeepGetParams route  -- reload to reflect changes
+
+    faHandler _ = addMessageI Error MsgErrorUnknownFormAction
+
+
+runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget
+runFirmActionFormPost cid route isAdmin acts = do
+  mr <- getMessageRender
+  ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin acts
+  let faAnchor  = "firm-action-form" :: Text
+      faRoute   = route :#: faAnchor
+      faForm    = wrapForm faWgt FormSettings
+                        { formMethod = POST
+                        , formAction = Just . SomeRoute $ faRoute
+                        , formEncoding = faEnctype
+                        , formAttrs = []
+                        , formSubmit = FormSubmit
+                        , formAnchor = Just faAnchor
+                        }
+  firmActionHandler route faRes
+  return [whamlet|
+          <section>
+            <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
+              _{MsgFirmAction}
+            <div>
+              <p>
+                _{MsgFirmActionInfo}
+              <P>
+                ^{faForm}
+        |]
+
+
 ---------------------------
 -- Firm specific utilities
 -- for filters and counts also see before FirmAllR Handlers
 
-postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
+
-postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged
 
 -- remove supervisors:
 deleteSupervisors :: NonEmpty UserId -> DB Int64
@@ -278,21 +446,6 @@ postFirmR fsh = do
 -----------------------
 -- All Firms Table
 
-data FirmAllAction = FirmAllActNotify
-                   | FirmAllActResetSupervision
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3
-embedRenderMessage ''UniWorX ''FirmAllAction id
-
-data FirmAllActionData = FirmAllActNotifyData
-                       | FirmAllActResetSupervisionData 
-                          { firmAllActResetKeepOldSupers      :: Maybe Bool 
-                          , firmAllActResetMutualSupervision  :: Maybe Bool
-                          }
-  deriving (Eq, Ord, Read, Show, Generic)
-
 -- just in case for future extensions
 type AllCompanyTableExpr = E.SqlExpr (Entity Company)
 queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
@@ -315,9 +468,10 @@ resultAllCompanyDefaultReroutes   :: Lens' AllCompanyTableData Bool
 resultAllCompanyDefaultReroutes   = _dbrOutput . _4 . _unValue
 
 
-mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget)
+mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
 mkFirmAllTable isAdmin uid = do
   -- now <- liftIO getCurrentTime
+  mr <- getMessageRender
   let
     resultDBTable = DBTable{..}
       where
@@ -325,7 +479,12 @@ mkFirmAllTable isAdmin uid = do
           unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
             usrCmpy <- E.from $ E.table @UserCompany
             E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
-                E.&&.  usrCmpy E.^. UserCompanyUser    E.==. E.val uid
+                E.&&. ((usrCmpy E.^. UserCompanyUser    E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor)
+                 E.||. E.exists (do
+                  usrSpr <- E.from $  E.table @UserSupervisor
+                  E.where_ $ usrSpr E.^. UserSupervisorUser       E.==. usrCmpy E.^. UserCompanyUser
+                      E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
+                ))
           return  ( cmpy                                        --  1
                   , cmpy & firmCountUsers                       --  2
                   , cmpy & firmHasSupervisors                   --  3
@@ -427,21 +586,12 @@ mkFirmAllTable isAdmin uid = do
           , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
-        acts :: Map FirmAllAction (AForm Handler FirmAllActionData)
-        acts = mconcat
-          [ singletonMap FirmAllActNotify           $ pure FirmAllActNotifyData
-          , singletonMap FirmAllActResetSupervision $      FirmAllActResetSupervisionData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep)         (Just $ Just False)
-              <*> aopt checkBoxField                                      (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True )
-          ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
           , dbParamsFormAction = Nothing
           , dbParamsFormAttrs  = []
           , dbParamsFormSubmit = FormSubmit
-          , dbParamsFormAdditional
+          , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision]
-              = renderAForm FormStandard $ (, mempty) . First . Just
-                  <$> multiActionA acts (fslI MsgTableAction) Nothing
           , dbParamsFormEvaluate = liftHandler . runFormPost
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
@@ -452,14 +602,14 @@ mkFirmAllTable isAdmin uid = do
         dbtCsvDecode = Nothing
         dbtExtraReps = []
 
-    postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData)
+    postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData)
-                -> FormResult (      FirmAllActionData, Set CompanyId)
+                -> FormResult (      FirmActionData, Set CompanyId)
     postprocess inp = do
         (First (Just act), cmpMap) <- inp
         let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap
         return (act, cmpSet)
 
-    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
+    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData))
     resultDBTableValidator = def
       & defaultSorting  [SortAscBy "short"]
   over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
@@ -469,33 +619,9 @@ getFirmAllR, postFirmAllR :: Handler Html
 getFirmAllR = postFirmAllR
 postFirmAllR = do
   uid <- requireAuthId
-  isAdmin <- hasReadAccessTo AdminR
+  isAdmin <- checkAdmin
   (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
-  formResult firmRes $ \case    
+  firmActionHandler FirmAllR firmRes
-    (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected
-
-    (FirmAllActResetSupervisionData{..}, fids) -> do
-      runDB $ do
-        delSupers <- if firmAllActResetKeepOldSupers == Just False
-          then E.deleteCount $ do
-                spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ E.exists $ do
-                  usr <- E.from $ E.table @UserCompany
-                  E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
-                      E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser 
-          else return 0 
-        newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids         
-        addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
-      reloadKeepGetParams FirmAllR -- reload to reflect changes
-
-    (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 fids
-        return $ usr E.^. UserId
-      cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
-      redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
-
   siteLayoutMsg MsgMenuFirms $ do
     setTitleI MsgMenuFirms
     $(i18nWidgetFile "firm-all")
@@ -504,28 +630,11 @@ postFirmAllR = do
 -----------------------
 -- Firm Users Table
 
-data FirmUserChangeRequest = FirmUserChangeRequest
-      { fucrPostalPref :: Maybe Bool 
-      , fucrPostalAddr :: Maybe StoredMarkup
-      }
-  deriving (Eq, Ord, Show, Generic)
-
-instance Default FirmUserChangeRequest where
-  def = FirmUserChangeRequest
-          { fucrPostalPref = Nothing
-          , fucrPostalAddr = Nothing
-          }
-
-makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest
-makeFirmUserChangeRequestForm template html = do 
-  flip (renderAForm FormStandard) html $ FirmUserChangeRequest
-    <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip)  (fucrPostalPref <$> template)
-    <*> aopt htmlField        (fslI MsgPostAddress   & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template)
-    
 
 data FirmUserAction = FirmUserActNotify
                     | FirmUserActResetSupervision
                     | FirmUserActMkSuper
+                    | FirmUserActChangeContact
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -539,7 +648,10 @@ data FirmUserActionData = FirmUserActNotifyData
                             }
                         | FirmUserActMkSuperData
                             { firmUserActMkSuperReroute   :: Maybe Bool }
-
+                        | FirmUserActChangeContactData
+                            { firmUserActPostalAddr :: Maybe StoredMarkup
+                            , firmUserActPostalPref :: Maybe Bool
+                            }
   deriving (Eq, Ord, Show, Generic)
 
 type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)
@@ -675,8 +787,8 @@ mkFirmUserTable isAdmin cid = do
         -- superField = selectField $ ????
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
-          , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField)  (fslI MsgFilterSupervisor)
+          , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece)     mPrev $ aopt (hoistField lift supervisorField)  (fslI MsgFilterSupervisor)
-          -- , prismAForm (multiFilter     "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
+          , prismAForm (multiFilter     "supervisors-are"        . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
           , prismAForm (singletonFilter "has-supervisor"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
           , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
           , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
@@ -686,10 +798,13 @@ mkFirmUserTable isAdmin cid = do
         acts = mconcat
           [ singletonMap FirmUserActNotify      $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep)         (Just $ Just False)
+              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
-              -- <*> aopt checkBoxField                                      (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True )
+              -- <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
+          , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
+              <$> aopt htmlField                        (fslI MsgPostAddress    & setTooltip MsgPostAddressTip)     Nothing
+              <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip)   Nothing
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -716,7 +831,7 @@ mkFirmUserTable isAdmin cid = do
         let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
         return (act, s)
 
-    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
+    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData))
     resultDBTableValidator = def
       & defaultSorting  [SortAscBy "user-name"]
   over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
@@ -725,7 +840,7 @@ mkFirmUserTable isAdmin cid = do
 getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
 getFirmUsersR  = postFirmUsersR
 postFirmUsersR fsh = do
-  isAdmin <- hasReadAccessTo AdminR
+  isAdmin <- checkAdmin
   let cid = CompanyKey fsh
   ((    Entity{entityVal=Company{..}}
       , E.Value nrCompanyUsers
@@ -760,7 +875,7 @@ postFirmUsersR fsh = do
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
       nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
-      addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing
+      addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmUserActNotifyData , uids) -> do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
@@ -773,32 +888,21 @@ postFirmUsersR fsh = do
         newSupers <- addDefaultSupervisors cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActChangeContactData{..}, Set.toList -> uids) ->
+      let changes = catMaybes
+            [ (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr  -- note that Nothing means no change and not delete address!
+            , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
+            ]
+      in unless (null changes) $ do
+        nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
+        addMessageI Success $ MsgFirmUserChanges nrChanged
+        reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
-  ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def)
+  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
-  let addFormAnchor = "firm-user-change-form" :: Text
-      routeForm = FirmUsersR fsh :#: addFormAnchor
-      fucrForm = wrapForm fucrWgt FormSettings  
-                        { formMethod = POST
-                        , formAction = Just . SomeRoute $ routeForm
-                        , formEncoding = fucrEnctype
-                        , formAttrs = []
-                        , formSubmit = FormSubmit
-                        , formAnchor = Just addFormAnchor
-                        }
-  formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do
-    let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp])     fucrPostalPref <>
-                  foldMap (\pa -> [UserPostAddress   E.=. E.justVal pa]) fucrPostalAddr      -- seems weird, but: Nothing means no change, and not delete address!
-    nrChanged <- runDB $ E.updateCount $ \usr -> do
-        E.set usr changes 
-        E.where_ $ E.exists $ do
-          usrCmpy <- E.from $ E.table @UserCompany
-          E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
-              E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
-    addMessageI Info $ MsgFirmUserChanges nrChanged
-    reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
   siteLayout (citext2widget companyName) $ do
     setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
+    let firmContactInfo = $(widgetFile "firm-contact-info")
     $(widgetFile "firm-users")
 
 
@@ -821,28 +925,6 @@ data FirmSuperActionData = FirmSuperActNotifyData
   deriving (Eq, Ord, Show, Generic)
 
 
-data AddSupervisorRequest = AddSupervisorRequest
-  {  asReqSupers  :: Set Text
-  ,  asReqReroute :: Bool
-  ,  asReqPostal  :: Maybe Bool
-  } deriving (Eq, Ord, Show, Generic)
-
-instance Default AddSupervisorRequest where 
-  def = AddSupervisorRequest 
-          { asReqSupers   = mempty
-          , asReqReroute  = True
-          , asReqPostal   = Nothing
-          }
-
-makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest
-makeAddSupervisorForm template html = do   
-  flip (renderAForm FormStandard) html $ AddSupervisorRequest
-    <$> areq (textField & cfAnySeparatedSet) 
-                              (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template)
-    <*> areq checkBoxField    (fslI MsgTableIsDefaultReroute )                      (asReqReroute <$> template)
-    <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip)  (asReqPostal <$> template)
-
-
 type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany))
 
 querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
@@ -983,7 +1065,7 @@ mkFirmSuperTable isAdmin cid = do
 getFirmSupersR, postFirmSupersR :: CompanyShorthand ->  Handler Html
 getFirmSupersR = postFirmSupersR
 postFirmSupersR fsh = do
-  isAdmin <- hasReadAccessTo AdminR
+  isAdmin <- checkAdmin
   let cid = CompanyKey fsh
   (Company{..},(fsprRes,fsprTable)) <- runDB $ (,)
     <$> get404 cid
@@ -1011,44 +1093,18 @@ postFirmSupersR fsh = do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
 
-  ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def)
+  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
-  let addSuperAnchor = "add-supervisors-form" :: Text
-      routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor
-      addSuperForm = wrapForm asReqWgt FormSettings  
-                        { formMethod = POST
-                        , formAction = Just . SomeRoute $ routeAddSuperForm
-                        , formEncoding = asReqEnctype
-                        , formAttrs = []
-                        , formSubmit = FormSubmit
-                        , formAnchor = Just addSuperAnchor
-                        }
-  formResult asReqRes $ \AddSupervisorRequest{..} -> do
-    avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers
-    let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
-        usersFound = mapMaybe snd usersFound'
-    unless (null usersNotFound) $
-      let msgContent = [whamlet|
-            $newline never
-            <ul>
-              $forall (usr,_) <- usersNotFound
-                <li>#{usr}
-            |]
-       in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-    when (null usersFound) $ do
-      addMessageI Warning MsgASReqEmpty
-      redirect routeAddSuperForm
-    runDB $ do
-      putMany [UserCompany uid cid True asReqReroute | uid <- usersFound]
-      whenIsJust asReqPostal $ \prefPostal ->
-        updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
-      addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal
-    redirect $ FirmSupersR fsh
 
   siteLayout (citext2widget fsh) $ do
     setTitle $ citext2Html $ fsh <> " Supers"
+    let firmContactInfo = $(widgetFile "firm-contact-info")
     $(i18nWidgetFile "firm-supervisors")
 
 
+------------------------
+-- Firm Communications
+
+
 getFirmCommR,  postFirmCommR :: CompanyShorthand -> Handler Html
 getFirmCommR = postFirmCommR
 postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh]

src/Handler/Profile.hs

@@ -70,6 +70,9 @@ data SettingsForm = SettingsForm
       , stgPrefersPostal        :: Bool
       , stgPostAddress          :: Maybe StoredMarkup
       
+      , stgTelephone            :: Maybe Text
+      , stgMobile               :: Maybe Text
+
       , stgExamOfficeSettings   :: ExamOfficeSettings
       , stgSchools              :: Set SchoolId
       , stgNotificationSettings :: NotificationSettings
@@ -129,9 +132,12 @@ makeSettingForm template html = do
         <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template)
 
         <*  aformSection MsgFormNotifications
-        <*> aopt  (textField & cfStrip) (fslI MsgPDFPassword   & setTooltip MsgPDFPasswordTip) (stgPinPassword   <$> template)
+        <*> aopt  (textField & cfStrip) (fslI MsgPDFPassword      & setTooltip MsgPDFPasswordTip) (stgPinPassword   <$> template)
         <*> apopt checkBoxField         (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip)      (stgPrefersPostal <$> template)
-        <*> aopt  htmlField             (fslI MsgPostAddress   & setTooltip MsgPostAddressTip) (stgPostAddress   <$> template)
+        <*> aopt  htmlField             (fslI MsgPostAddress      & setTooltip MsgPostAddressTip) (stgPostAddress   <$> template)
+
+        <*> aopt  (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template)
+        <*> aopt  (textField & cfStrip) (fslI MsgUserMobile   ) (stgMobile    <$> template)      
 
         <*> examOfficeForm (stgExamOfficeSettings <$> template)        
         <*> schoolsForm (stgSchools <$> template)
@@ -362,14 +368,14 @@ validateSettings User{..} = do
     validEmail' userDisplayEmail'
 
   userPostAddress'  <- use _stgPostAddress
-  let postalNotSet  = isNothing userPostAddress'
+  let postalNotSet  = isNothing userPostAddress' -- TODO $ canonical userPostAddress'
       postalIsValid = validPostAddress userPostAddress'
   guardValidation MsgUserPostalInvalid $
     postalNotSet || postalIsValid
 
   userPrefersPostal' <- use _stgPrefersPostal
   guardValidation MsgUserPrefersPostalInvalid $
-    not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment)
+    not $ userPrefersPostal' && postalNotSet && isNothing userCompanyDepartment
 
   userPinPassword'  <- use _stgPinPassword
   let pinBad     = validCmdArgument =<< userPinPassword'
@@ -439,6 +445,8 @@ serveProfileR (uid, user@User{..}) = do
         , stgPinPassword          = userPinPassword
         , stgPostAddress          = userPostAddress
         , stgPrefersPostal        = userPrefersPostal  
+        , stgTelephone            = userTelephone
+        , stgMobile               = userMobile
         , stgExamOfficeSettings   = ExamOfficeSettings
                                     { eosettingsGetSynced = userExamOfficeGetSynced
                                     , eosettingsGetLabels = userExamOfficeGetLabels
@@ -467,9 +475,11 @@ serveProfileR (uid, user@User{..}) = do
         , UserWarningDays          =. stgWarningDays
         , UserNotificationSettings =. stgNotificationSettings
         , UserShowSex              =. stgShowSex
-        , UserPinPassword          =. stgPinPassword
+        , UserPinPassword          =. (stgPinPassword & canonical)
-        , UserPostAddress          =. stgPostAddress
+        , UserPostAddress          =. (stgPostAddress & canonical)
         , UserPrefersPostal        =. stgPrefersPostal
+        , UserTelephone            =. (stgTelephone   & canonical)
+        , UserMobile               =. (stgMobile      & canonical)
         , UserExamOfficeGetSynced  =. (stgExamOfficeSettings & eosettingsGetSynced)
         , UserExamOfficeGetLabels  =. (stgExamOfficeSettings & eosettingsGetLabels)
         ]

src/Handler/Submission/List.hs

@@ -397,7 +397,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $
       csh = x ^. resultCourseShorthand
       shn = x ^. resultSheet . _entityVal . _sheetName
       subCID = x ^. resultCryptoID
-   in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID)
+   in anchorCell (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID)
 
 colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
 colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return

src/Handler/Utils.hs

@@ -146,7 +146,7 @@ redirectAlternatives = go
 reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
 reload r = getCurrentRoute >>= redirect . fromMaybe r
 
--- | like `reload`, preserving all GET parameters
+-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known
 reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
 reloadKeepGetParams r = liftHandler $ do 
   getps <- reqGetParams <$> getRequest
@@ -155,7 +155,7 @@ reloadKeepGetParams r = liftHandler $ do
   -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
   redirect (route, getps) 
 
--- | redirect preserving all GET parameters
+-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
 redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
 redirectKeepGetParams route = liftHandler $ do 
   getps <- reqGetParams <$> getRequest  

src/Handler/Utils/Table/Cells.hs

@@ -226,7 +226,7 @@ cellHasUserModal toLink user =
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
       lWdgt = do 
                 uuid <- liftHandler $ encrypt uid
-                modal nWdgt (Left $ SomeRoute $ toLink uuid)
+                modalAccess False nWdgt nWdgt $ toLink uuid                
   in cell lWdgt
 
 -- | like `cellHasUserModal` but with fixed route and showing an edit icon instead
@@ -237,7 +237,7 @@ cellEditUserModal user =
       nWdgt = toWidget $ icon IconUserEdit      
       lWdgt = do 
                 uuid <- liftHandler $ encrypt uid
-                modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
+                modalAccess True nWdgt mempty $ ForProfileR uuid
   in cell lWdgt
 cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
 cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
@@ -246,7 +246,7 @@ cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell
 cellHasMatrikelnummerLinked usr 
     | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do 
         uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
-        modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
+        modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid)
     | otherwise = mempty
   where 
     usrEntity = usr ^. hasEntityUser
@@ -364,7 +364,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
     Nothing     -> headWgt <> dateWgt
     Just toLink -> do 
       uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
-      let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid)
+      let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid
       headWgt <> modalWgt
   where       
     dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
@@ -385,7 +385,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
     dc tstamp 
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
-          modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)        
+          let dWgt = formatTimeW SelFormatDate tstamp
+          modalAccess False dWgt dWgt $ toLink uuid
         --  anchorCellM (toLink <$> encrypt uid) 
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -403,7 +404,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
     dc tstamp 
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
-          modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)        
+          let dWgt = formatTimeW SelFormatDate tstamp
+          modalAccess False dWgt dWgt $ toLink uuid
         --  anchorCellM (toLink <$> encrypt uid) 
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -463,7 +465,8 @@ avsPersonNoCell = numCell . view _userAvsNoPerson
 avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
 avsPersonNoLinkedCell a = cell $ do
   uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
-  modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid)
+  let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
+  modalAccess False nWgt nWgt $ AdminAvsUserR uuid
 
 avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
 avsPersonCardCell cards = wgtCell 

src/Handler/Utils/Widgets.hs

@@ -123,6 +123,15 @@ editedByW fmt tm usr  = do
   [whamlet|_{MsgUtilEditedBy usr ft}|]
 
 
+-- | like `modal`, but checks access rights to the link
+modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget
+modalAccess writeAccess wdgtYes wdgtNo route = do
+  authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
+  if authOk
+    then modal wdgtYes (Left $ SomeRoute route)
+    else       wdgtNo
+
+
 ----------
 -- HEAT --
 ----------

src/Model/Types/Markup.hs

@@ -50,6 +50,13 @@ data StoredMarkup = StoredMarkup
   deriving (Read, Show, Generic)
   deriving anyclass (Binary, Hashable, NFData)
 
+instance Canonical (Maybe StoredMarkup) where
+  canonical Nothing  = Nothing
+  canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if
+    | LT.null mi'        -> Nothing
+    | markupInput == mi' -> r
+    | otherwise          -> Just s{markupInput = mi'}
+
 htmlToStoredMarkup :: Html -> StoredMarkup
 htmlToStoredMarkup html = StoredMarkup
   { markupInputFormat = MarkupHtml

src/Utils.hs

@@ -1986,3 +1986,17 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca
 -- this instance is more of a convenient abuse of the class (expand to Foldable)
 instance (Ord a, Canonical a) => Canonical (Set a) where
   canonical = Set.map canonical
+
+instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome
+  canonical Nothing     = Nothing
+  canonical r@(Just t)  = let t' = Text.strip t in if
+    | Text.null t' -> Nothing
+    | t == t'      -> r
+    | otherwise    -> Just t'
+
+instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome
+  canonical Nothing     = Nothing
+  canonical r@(Just t)  = let t' = CI.map Text.strip  t in if
+    | mempty == t'-> Nothing
+    | t == t'     -> r
+    | otherwise   -> Just t'

src/Utils/Form.hs

@@ -318,6 +318,7 @@ data FormIdentifier
   | FIDHijackUser
   | FIDAddSupervisor
   | FIDFirmUserChangeRequest
+  | FIDFirmAction
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where

src/Utils/Frontend/Modal.hs

@@ -38,7 +38,7 @@ customModal Modal{..} = do
   route <- traverse toTextUrl $ modalContent ^? _Left
   modalTrigger route triggerId'
 
--- | Create a link to a modal
+-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant
 modal :: WidgetFor site () -- ^ Widget that represents the link
       -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget
       -> WidgetFor site () -- ^ result widget

templates/firm-contact-info.hamlet

@@ -0,0 +1,27 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section .profile>
+  <h2>_{MsgFirmContact}
+  <dl .deflist.profile-dl>
+    $maybe fem <- companyEmail
+      <dt .deflist__dt>
+        _{MsgFirmEmail} 
+        $if not companyPrefersPostal 
+          &nbsp; #{iconLetterOrEmail False} 
+      <dd .deflist__dd .email>
+        #{mailtoHtml fem}
+    $maybe addr <- companyPostAddress
+      <dt .deflist__dt>
+        _{MsgFirmAddress}
+        $if companyPrefersPostal 
+          &nbsp; #{iconLetterOrEmail True} 
+      <dd .deflist__dd>
+        #{addr}
+    $nothing
+      $maybe _ <- companyEmail
+      $nothing
+        _{MsgFirmNoContact}

templates/firm-users.hamlet

@@ -4,18 +4,9 @@ $# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
-<section .profile>     
+^{firmContactInfo}
-  <dl .deflist.profile-dl>
+
-    $maybe fem <- companyEmail
+^{formFirmAction}
-      <dt .deflist__dt>
-        _{MsgFirmEmail} #{iconLetterOrEmail False} 
-      <dd .deflist__dd .email>
-        #{mailtoHtml fem}
-    $maybe addr <- companyPostAddress
-      <dt .deflist__dt>
-        _{MsgFirmAddress} #{iconLetterOrEmail True} 
-      <dd .deflist__dd>
-        #{addr}
 
 <section>        
   <div .scrolltable .scrolltable--bordered>
@@ -66,6 +57,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     _{MsgFirmAssociates}
   <p>
     ^{fusrTable}
-
-<section>
-  ^{fucrForm}

templates/i18n/firm-supervisors/de-de-formal.hamlet

@@ -9,19 +9,13 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist 
   und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, 
   dass dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
-<section .profile>     
+
-  <dl .deflist.profile-dl>
+^{firmContactInfo}  
-    $maybe fem <- companyEmail
+
-      <dt .deflist__dt>
+^{formFirmAction}
-        _{MsgFirmEmail} #{iconLetterOrEmail False} 
+
-      <dd .deflist__dd .email>
-        #{mailtoHtml fem}
-    $maybe addr <- companyPostAddress
-      <dt .deflist__dt>
-        _{MsgFirmAddress} #{iconLetterOrEmail True} 
-      <dd .deflist__dd>
-        #{addr}
 <section>
-  ^{fsprTable}
+  <h2>
-<section>
+    _{MsgTableSupervisor}
-  ^{addSuperForm}
+  <div>
+    ^{fsprTable}

templates/i18n/firm-supervisors/en-eu.hamlet

@@ -8,19 +8,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   Note that supervision is company independent. 
   For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, 
   then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
-<section .profile>     
+
-  <dl .deflist.profile-dl>
+^{firmContactInfo}
-    $maybe fem <- companyEmail
+
-      <dt .deflist__dt>
+^{formFirmAction}
-        _{MsgFirmEmail} #{iconLetterOrEmail False} 
+
-      <dd .deflist__dd .email>
-        #{mailtoHtml fem}
-    $maybe addr <- companyPostAddress
-      <dt .deflist__dt>
-        _{MsgFirmAddress} #{iconLetterOrEmail True} 
-      <dd .deflist__dd>
-        #{addr}
 <section>
-  ^{fsprTable}
+  <h2>
-<section>
+    _{MsgTableSupervisor}
-  ^{addSuperForm}  
+  <div>
+    ^{fsprTable}
+