chore(firm): add action to add non-avs firm associates

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

@@ -21,8 +21,11 @@ FirmActResetSupersKeepAll: Alle behalten
 FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
 FirmActResetSupersRemoveAll: Alle entfernen
 FirmActAddSupervisors: Ansprechpartner hinzufügen
-FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
+FirmActAddAssociates: Firmenangehörige hinzufügen
+FirmActAddSupersEmpty: Es konnten keine neuen Ansprechpartner hinzugefügt werden!
 FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
+FirmActAddAssocsEmpty: Es konnten keine neuen Firmenangehörige hinzugefügt werden!
+FirmActAddAssocs n@Int64: #{n} Firmenangehörige hinzugefügt.
 RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt. 
 FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern

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

@@ -21,8 +21,11 @@ FirmActResetSupersKeepAll: Keep all
 FirmActResetSupersRemoveAps: Remove default supervisors only
 FirmActResetSupersRemoveAll: Remove all
 FirmActAddSupervisors: Add supervisors
-FirmActAddSupersEmpty: No supervisors added
+FirmActAddAssociates: Associate users with company
+FirmActAddSupersEmpty: No new supervisors added!
 FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
+FirmActAddAssocsEmpty: No new company associated users added!
+FirmActAddAssocs n@Int64: #{pluralENsN n "company associated user"} added.
 RemoveSupervisors ndef: #{ndef} default supervisors removed.
 FirmActChangeContactUser: Change contact data for all company associates
 FirmActChangeContactFirm: Change company contact data

src/Handler/Firm.hs

@@ -54,6 +54,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
 data FirmAction = FirmActNotify
                 | FirmActResetSupervision
                 | FirmActAddSupervisors
+                | FirmActAddAssociates
                 | FirmActChangeContactFirm
                 | FirmActChangeContactUser
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -64,24 +65,31 @@ embedRenderMessage ''UniWorX ''FirmAction id
 
 data FirmActionData = FirmActNotifyData
                     | FirmActResetSupervisionData
-                        { firmActResetKeepOldSupers       :: Maybe Bool
+                        { firmActResetKeepOldSupers         :: Maybe Bool
-                        , firmActResetMutualSupervision   :: Maybe Bool
+                        , firmActResetMutualSupervision     :: Maybe Bool
                         }
                     | FirmActAddSupervisorsData
-                        { firmActAddSupervisorIds         :: Set Text
+                        { firmActAddUserIds                 :: Set Text
-                        , firmActAddSupervisorReroute     :: Bool
+                        , firmActAddSupervisorReroute       :: Bool
-                        , firmActAddSupervisorPostal      :: Maybe Bool
+                        , firmActAddSupervisorPostal        :: Maybe Bool
-                        , firmActAddSupervisorReason      :: Maybe Text
+                        , firmActAddUserUseCompanyAddress   :: Bool
+                        , firmActAddSupervisorReason        :: Maybe Text
+                        }
+                    | FirmActAddAssociatesData
+                        { firmActAddUserIds                 :: Set Text
+                        , firmActAddAssociatePriority       :: Int
+                        , firmActAddUserUseCompanyAddress   :: Bool
+                        , firmActAddAssociateReason         :: Maybe Text
                         }
                     | FirmActChangeContactFirmData
-                        { firmActCCFPostalAddr            :: Maybe StoredMarkup
+                        { firmActCCFPostalAddr              :: Maybe StoredMarkup
-                        , firmActCCFEmail                 :: Maybe UserEmail
+                        , firmActCCFEmail                   :: Maybe UserEmail
-                        , firmActCCFPostalPref            :: Maybe Bool
+                        , firmActCCFPostalPref              :: Maybe Bool
                         }
                     | FirmActChangeContactUserData
-                        { firmActCCUPostalAddr            :: Maybe StoredMarkup
+                        { firmActCCUPostalAddr              :: Maybe StoredMarkup
-                        , firmActCCUUseCompanyPostal      :: Maybe Bool
+                        , firmActCCUUseCompanyPostal        :: Maybe Bool
-                        , firmActCCUPostalPref            :: Maybe Bool
+                        , firmActCCUPostalPref              :: Maybe Bool
                         }
   deriving (Eq, Ord, Read, Show, Generic)
 
@@ -93,11 +101,18 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
                   <$> aopt boolField'                       (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
                   <*> aopt checkBoxField                    (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
     mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
-                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)          Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
+                  <*> areq checkBoxField                    (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip)      (Just True)
                   <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
                                                             (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip)                        Nothing
+    mkAct _     FirmActAddAssociates    = singletonMap FirmActAddAssociates    $ FirmActAddAssociatesData
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgFirmAssociates & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)            Nothing
+                  <*> areq intField                         (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip)                        (Just 0)
+                  <*> areq checkBoxField                    (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip)      (Just True)
+                  <*> aopt (textField & cfStrip & addDatalist ucdefAssocReasons)
+                                                            (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip)                        Nothing
     mkAct _     FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                   <*> aopt (emailField & cfStrip & cfCI)    (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
@@ -112,7 +127,15 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
     ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
       fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
         usrc <- E.from $ E.table @UserCompany
-        E.where_ $ E.isJust $ usrc E.^. UserCompanyReason
+        E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
+            E.&&.  usrc E.^. UserCompanySupervisor
+        return $ usrc E.^. UserCompanyReason
+    ucdefAssocReasons :: HandlerFor UniWorX (OptionList Text)
+    ucdefAssocReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+      fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+        usrc <- E.from $ E.table @UserCompany
+        E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
+            E.&&.  E.not__ (usrc E.^. UserCompanySupervisor)
         return $ usrc E.^. UserCompanyReason
 
 
@@ -158,7 +181,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
       reloadKeepGetParams route -- reload to reflect changes
 
     faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
-      avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
+      avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddUserIds
       let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
           usersFound = mapMaybe snd usersFound'
       unless (null usersNotFound) $
@@ -175,12 +198,38 @@ firmActionHandler route isAdmin = flip formResult faHandler
       runDB $ do
         -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
         -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
-        upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
+        upsertManyWhere
+          [UserCompany uid cid True firmActAddSupervisorReroute 0 firmActAddUserUseCompanyAddress firmActAddSupervisorReason | uid <- usersFound]
+          []
+          [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason]
+          [] -- identical to previous line, but perhaps more clear?
         whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
           updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
         addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
       redirect route
 
+    faHandler (FirmActAddAssociatesData{..}, Set.toList -> [cid]) = do
+      avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddUserIds
+      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 MsgFirmActAddAssocsEmpty
+        reloadKeepGetParams route
+      runDB $ do
+        oks0 <- mapM insertUnique_ [UserCompany uid cid False False firmActAddAssociatePriority firmActAddUserUseCompanyAddress firmActAddAssociateReason | uid <- usersFound]
+        let oks = length $ catMaybes oks0
+            allok = bool Warning Success $ oks == length usersFound
+        addMessageI allok $ MsgFirmActAddAssocs (fromIntegral oks)
+      redirect route
+
     faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) =
       let changes = catMaybes
             [ (CompanyPostAddress   =.) . Just <$> canonical firmActCCFPostalAddr
@@ -1139,7 +1188,7 @@ postFirmUsersR fsh = do
       addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
-  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
+  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddAssociates, FirmActChangeContactFirm, FirmActChangeContactUser]
 
   siteLayout (citext2widget companyName) $ do
     setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId

src/Utils/DB.hs

@@ -222,6 +222,18 @@ checkUniqueKeys (x:xs) = do
         Nothing -> checkUniqueKeys xs
         Just _ -> return (Just x)
 
+-- Backport from version persistent-2.14.6.3
+insertUnique_ :: ( MonadIO m
+             , PersistEntity record
+             , PersistUniqueWrite backend
+             , PersistEntityBackend record ~ BaseBackend backend
+            )
+    => record -> ReaderT backend m (Maybe ())
+insertUnique_ datum = do
+    conflict <- checkUnique datum
+    case conflict of
+        Nothing -> Just <$> insert_ datum
+        Just _ -> return Nothing
 
 put :: ( MonadIO m
        , PersistUniqueWrite backend