chore(firm): add messaging action (WIP)

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

@@ -13,6 +13,8 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
 FirmSuperActNotify: Mitteilung versenden
 FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen
 FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen
+FirmsNotification: Firmen Benachrichtigung versenden
+FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden
 FilterSupervisor: Hat aktiven Ansprechpartner
 FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört
 FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört

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

@@ -13,6 +13,8 @@ FirmUserActMkSuper: Mark as company supervisor
 FirmSuperActNotify: Send message
 FirmSuperActRMSuperDef: Remove as default supervisor
 FirmSuperActRMSuperAll: Remove all active supervisions for this company
+FirmsNotification: Send company notification
+FirmNotification fsh: Send notification to company #{fsh}
 FilterSupervisor: Has active supervisor
 FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
 FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}

routes

@@ -113,10 +113,13 @@
 /for/#CryptoUUIDUser/user         ForProfileR       GET POST    !supervisor !self
 /for/#CryptoUUIDUser/user/profile ForProfileDataR   GET         !supervisor !self
 
-/firm                           FirmAllR            GET POST		!supervisor
+/firms                          FirmAllR            GET POST		!supervisor
+/firms/comm    									FirmsCommR          GET POST
 /firm/#CompanyShorthand         FirmR               GET POST
 /firm/#CompanyShorthand/users   FirmUsersR          GET POST    !supervisor
 /firm/#CompanyShorthand/supers  FirmSupersR         GET POST    !supervisor
+/firm/#CompanyShorthand/comm    FirmCommR 	        GET POST    
+
 
 /exam-office               ExamOfficeR                         !exam-office:
   /                        EOExamsR            GET POST        !system-exam-office

src/Handler/Firm.hs

@@ -11,6 +11,8 @@ module Handler.Firm
   , getFirmR      , postFirmR
   , getFirmUsersR , postFirmUsersR
   , getFirmSupersR, postFirmSupersR
+  , getFirmCommR  , postFirmCommR
+  , getFirmsCommR,  postFirmsCommR
   )
   where
 
@@ -18,6 +20,7 @@ import Import
 
 -- import Jobs
 import Handler.Utils
+import Handler.Utils.Communication
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -494,8 +497,10 @@ mkFirmUserTable isAdmin cid = do
                   Just True   -> E.exists    checkSuper
                   Just False  -> E.notExists checkSuper
           ]
+        -- superField = selectField $ ????
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
+          , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
           , 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)
@@ -541,7 +546,7 @@ getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
 getFirmUsersR  = postFirmUsersR
 postFirmUsersR fsh = do
   isAdmin <- hasReadAccessTo AdminR
-  let fshId = CompanyKey fsh
+  let cid = CompanyKey fsh
   ((    Entity{entityVal=Company{..}}
       , E.Value nrCompanyUsers
       , E.Value nrCompanySupervisors
@@ -551,10 +556,10 @@ postFirmUsersR fsh = do
       , E.Value nrCompanyEmployeeRerPost
       , E.Value nrCompanyDefaultReroutes
       , E.Value nrCompanyActiveReroutes
-   )  , (fusrRes, fusrTable)) <- runDB $ (,)
+   )  , (fusrRes, fusrTable)) <- runDB $ (,) 
       <$> fromMaybeM notFound (E.selectOne $ do
           cmpy <- E.from $ E.table @Company
-          E.where_ $ cmpy E.^. CompanyId E.==. E.val fshId
+          E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
           return  ( cmpy
                   , cmpy & firmCountUsers
                   , cmpy & firmCountSupervisors
@@ -565,11 +570,18 @@ postFirmUsersR fsh = do
                   , cmpy & firmCountDefaultReroutes
                   , cmpy & firmCountActiveReroutes
                   ))
-      <*> mkFirmUserTable isAdmin fshId
+      -- superVs <- E.select $ do 
+      --     usr <- E.from $ E.table @User
+      --     E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
+      --     return usr
+      <*> mkFirmUserTable isAdmin cid      
 
-  formResult fusrRes $ \case
+  formResult fusrRes $ \case    
-    (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO"
     (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make "  <> tshow (length fids) <> " employees to supervisors. TODO"
+    (FirmUserActNotifyData , fids) -> do 
+      cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser]
+      redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
+
   siteLayout (citext2widget companyName) $ do
     setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
     $(widgetFile "firm-users")
@@ -755,3 +767,79 @@ postFirmSupersR fsh = do
       <section>
         ^{fsprTable}
     |]
+
+
+getFirmCommR,  postFirmCommR :: CompanyShorthand -> Handler Html
+getFirmCommR = postFirmCommR
+postFirmCommR fsh = handleFirmCommR (SomeRoute FirmUsersR) (Just fsh)
+
+
+getFirmsCommR,  postFirmsCommR :: Handler Html
+getFirmsCommR = postFirmsCommR
+postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing
+
+
+handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html
+handleFirmCommR ultDest mbFsh = do
+  let decrypt' :: CryptoUUIDUser -> Handler UserId
+      decrypt' = decrypt
+
+      mbCid = CompanyKey <$> mbFsh  
+
+      -- queryEmpys :: CompanyId -> Handler [UserId]
+      queryEmpys cid = E.unValue <<$>> runDB (E.select $ do
+          (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
+          E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid
+          return $ emp E.^. UserId
+        )
+
+  chosen <- mapM decrypt =<< lookupGlobalGetParams GetRecipient   -- retrieve selected users
+  empys <- maybe (return chosen) queryEmpys mbCid                 -- get all employees or stick with selected users, if no company was pre-selected (to limit choices)
+  
+  cmpys <- runDB $ E.select $ do
+      cmpy <- E.from $ E.table @Company
+      E.where_ $ E.exists $ do 
+        usrCmpy <- E.table @UserCompany
+        E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList chosen
+            E.&&.  usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
+      return $ cmpy E.^.CompanyId
+
+  let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
+      queryCmpy sORe acid = do 
+        (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
+        E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid
+            E.&&. (if sORe 
+              then -- supervisors only
+                E.exists $ do 
+                  usrSpr <- E.table @UserSupervisor 
+                  E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId 
+                      E.&&.  usrSpr E.^. UserSupervisorUser E.in_ E.valList empys
+              else -- chosen employees for this company only
+                usr E.^. UserId E.in_ E.valList empys
+            )          
+
+  commR CommunicationRoute
+    { crHeading   = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh
+    , crUltDest   = ultDest
+    , crJobs      = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()    
+    , crTestJobs  = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()    
+    , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult 
+    , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
+      [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True  acid)  | acid <- cmpys ] <>
+      [(RGFirmEmployees  $ unCompanyKey acid, queryCmpy False acid)  | acid <- cmpys ]
+    }
+
+{-
+  ??? x 
+
+  Alle Supervisor von Leuten in X, gruppiert nach Firma 
+  Alle Teilnehmer von X 
+
+  Ansprechpartner aus X 
+    - Fred
+  Ansprechpartner aus Y 
+    - Otto 
+  Angestellte aus X 
+    - Fred 
+    - Meier
+  -}

src/Handler/Utils/Communication.hs

@@ -30,6 +30,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect
                     | RGTutorialParticipants CryptoUUIDTutorial
                     | RGExamRegistered CryptoUUIDExam
                     | RGSheetSubmittor CryptoUUIDSheet
+                    | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand
   deriving (Eq, Ord, Read, Show, Generic)
 
 instance LowerBounded RecipientGroup where