refactor(firm): WIP generalize firm actions

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

@@ -8,6 +8,12 @@ FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt.
 FirmEmail: Allgemeine Email
 FirmAddress: Postanschrift
 FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
+FirmAction: Firmenweite Aktion
+FirmActNotify: Mitteilung versenden
+FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
+FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
+FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
+FirmActAddSupervisors: Ansprechpartner hinzufügen
 FirmAllActNotify: Mitteilung versenden
 FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?

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

@@ -8,11 +8,17 @@ FirmNoContact: No general contact information known.
 FirmEmail: General company email
 FirmAddress: Postal address
 FirmDefaultPreferenceInfo: Default setting for new company associates only
+FirmAction: Companywide action
+FirmActNotify: Send message
+FirmActResetSupervision: Reset supervisors for all company associates
+FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
+FirmActResetMutualSupervision: Supervisors supervise each other
+FirmActAddSupervisors: Add supervisors
 FirmAllActNotify: Send message
 FirmAllActResetSupervision: Reset supervisors for all company associates
-FirmUserActNotify: Send message
 FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates?
 FirmAllActResetMutualSupervision: Supervisors supervise each other
+FirmUserActNotify: Send message
 FirmUserActResetSupervision: Reset supervisors to company default
 FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
 FirmUserActMkSuper: Mark as company supervisor

src/Handler/Firm.hs

@@ -48,12 +48,134 @@ 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
+                -- | FirmActAddSupervisors
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''FirmAction $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''FirmAction id
+
+data FirmActionData = FirmActNotifyData
+                    | FirmActResetSupervisionData 
+                        { firmActResetKeepOldSupers      :: Maybe Bool 
+                        , firmActResetMutualSupervision  :: Maybe Bool
+                        }
+                    -- | FirmActAddSupervisorsData
+                    --     { firmActAddSupervisorIds     :: Set Text
+                    --     , firmActAddSupervisorReroute :: Bool
+                    --     , firmActAddSupervisorPostal  :: Maybe Bool
+                    --     }
+  deriving (Eq, Ord, Read, Show, Generic)
+
+firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData)
+firmActionMap acts = mconcat (mkAct <$> acts)
+  where
+    mkAct 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 FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $      FirmActAddSupervisorsData
+    --         <$> areq (textField & cfAnySeparatedSet)                    (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty)
+    --         <*> areq checkBoxField                                      (fslI MsgTableIsDefaultReroute )                          (Just True)
+    --         <*> aopt postalEmailField                                   (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip)  (Just Nothing)
+
+firmActionForm :: [FirmAction] -> AForm Handler FirmActionData
+firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing
+
+
+makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
+makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts
+
+-- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ())
+-- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm 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 Info $ 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 (FirmActAddSupervisorsData{..}, 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 MsgASReqEmpty
+    --     reloadKeepGetParams route
+    --   runDB $ do
+    --     putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
+    --     whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
+    --       updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
+    --     addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal
+    --   redirect route
+    -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction
+
+
+runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget
+runFirmActionFormPost cid route acts = do 
+  -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts
+  ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid 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> 
+              ^{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
@@ -315,7 +437,7 @@ 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
   let
@@ -432,21 +554,14 @@ 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 [FirmActNotify, FirmActResetSupervision]
-              = renderAForm FormStandard $ (, mempty) . First . Just
+          , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just 
-                  <$> multiActionA acts (fslI MsgTableAction) Nothing
+              <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing
           , dbParamsFormEvaluate = liftHandler . runFormPost
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
@@ -457,14 +572,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
@@ -475,32 +590,8 @@ getFirmAllR = postFirmAllR
 postFirmAllR = do
   uid <- requireAuthId
   isAdmin <- hasReadAccessTo AdminR
-  (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
+  (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
-  formResult firmRes $ \case    
+  -- 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")
@@ -1019,6 +1110,8 @@ postFirmSupersR fsh = do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
 
+  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors]
+
   ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def)
   let addSuperAnchor = "add-supervisors-form" :: Text
       routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor
@@ -1058,6 +1151,10 @@ postFirmSupersR fsh = do
     $(i18nWidgetFile "firm-supervisors")
 
 
+------------------------
+-- Firm Communications
+
+
 getFirmCommR,  postFirmCommR :: CompanyShorthand -> Handler Html
 getFirmCommR = postFirmCommR
 postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh]

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/Utils/Form.hs

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

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

@@ -12,6 +12,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 ^{firmContactInfo}  
 
+^{formFirmAction}
+
 <section>
   ^{fsprTable}
 

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

@@ -11,6 +11,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 ^{firmContactInfo}
 
+^{formFirmAction}
+
 <section>
   ^{fsprTable}