chore(firm): add working view for supervision discrepancy by firm

show if a supervisionship-company is unrelated to either supervisor or supervisee

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

@@ -83,3 +83,4 @@ CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterle
 CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!
 CompanySupervisorCompanyMissing fsh@CompanyShorthand: Empfänger ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert
 CompanySuperviseeCompanyMissing fsh@CompanyShorthand: Betroffener ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert
+ASChangeCompany: Firma ändern, welche Ansprechpartnerbeziehung begründet

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

@@ -81,5 +81,6 @@ CompanyUserPriorityTip: Company priority is relative to other company associatio
 CompanyUserUseCompanyAddress: Use company postal address
 CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
 CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
-CompanySupervisorCompanyMissing fsh: Reciver is not associated with #{fsh} given as reroute reason
+CompanySupervisorCompanyMissing fsh: Receiver is not associated with #{fsh} given as reroute reason
 CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisonship reason
+ASChangeCompany: Change company for supervisionship

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -138,6 +138,7 @@ MenuFirms: Firmen
 MenuFirmUsers: Angehörige
 MenuFirmSupervisors: Ansprechpartner
 MenuFirmsComm: Mitteilung
+MenuFirmsSupervision: Probleme Ansprechpartnerbeziehungen
 
 MenuInterfaces: Schnittstellen
 MenuSap: SAP Schnittstelle

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -138,6 +138,7 @@ MenuFirms: Companies
 MenuFirmUsers: Associates
 MenuFirmSupervisors: Supervisors
 MenuFirmsComm: Messaging
+MenuFirmsSupervision: Problems supervisionship
 
 MenuInterfaces: Interfaces
 MenuSap: SAP Interface 

routes

@@ -126,6 +126,7 @@
 
 /firms                          FirmAllR            GET POST		-- not yet !supervisor
 /firms/comm/+Companies          FirmsCommR          GET POST
+/firms/supervision              FirmsSupervisionR   GET POST
 /firm/#CompanyShorthand/comm    FirmCommR						GET POST
 /firm/#CompanyShorthand         FirmUsersR          GET POST    -- not yet !supervisor
 /firm/#CompanyShorthand/supers  FirmSupersR         GET POST    -- not yet !supervisor

src/Foundation/Navigation.hs

@@ -127,6 +127,7 @@ breadcrumb ConfigInterfacesR    = i18nCrumb MsgConfigInterfacesHeading    $ Just
 
 breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms              Nothing
 breadcrumb FirmsCommR{}     = i18nCrumb MsgMenuFirmsComm        $ Just   FirmAllR
+breadcrumb FirmsSupervisionR= i18nCrumb MsgMenuFirmsSupervision $ Just   FirmAllR
 breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAllR
 breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
 breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh
@@ -2457,6 +2458,12 @@ pageActions ApiDocsR = return
     , navChildren = []
     }
   ]
+pageActions FirmAllR = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
+    , navChildren = []
+    }
+  ]
 pageActions (FirmUsersR fsh) = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh

src/Handler/Firm.hs

@@ -11,7 +11,8 @@ module Handler.Firm
   , getFirmUsersR , postFirmUsersR
   , getFirmSupersR, postFirmSupersR
   , getFirmCommR  , postFirmCommR
-  , getFirmsCommR,  postFirmsCommR
+  , getFirmsCommR , postFirmsCommR
+  , getFirmsSupervisionR , postFirmsSupervisionR
   )
   where
 
@@ -1526,3 +1527,149 @@ handleFirmCommR ultDest cs = do
       Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
       Alle gewählten Personen, gruppiert nach deren Firma
   -}
+
+
+-----------------------
+-- Supervision Sanity
+
+data ActSupervision = ASChangeCompany
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''ActSupervision $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''ActSupervision id
+
+data ActSupervisionData = ASChangeCompanyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User)
+
+mkSupervisonTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget)
+mkSupervisonTable = over _1 postprocess <$> dbTable validator DBTable{..}
+  where
+    dbtIdent = "sanity-super" :: Text
+    dbtStyle = def
+
+    queryRelation     :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserSupervisor)
+    queryRelation     = $(E.sqlIJproj 3 1)
+    querySupervisor   :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
+    querySupervisor   = $(E.sqlIJproj 3 2)
+    querySubordinate  :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
+    querySubordinate  = $(E.sqlIJproj 3 3)
+
+    resultRelation     :: Lens' TblSupervisionData (Entity UserSupervisor)
+    resultRelation     =  _dbrOutput . _1
+    resultSupervisor   :: Lens' TblSupervisionData (Entity User)
+    resultSupervisor   =  _dbrOutput . _2
+    resultSubordinate  :: Lens' TblSupervisionData (Entity User)
+    resultSubordinate  =  _dbrOutput . _3
+
+    dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do
+      EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
+      EL.on $ uus E.^. UserSupervisorUser       E.==. sub E.^. UserId
+      let usrHasNotCmp qUsr = E.notExists $ do
+                                uc <- E.from $ E.table @UserCompany
+                                E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany
+                                    E.&&.  uc E.^. UserCompanyUser    E.==. uus E.^. qUsr
+      E.where_ $ E.isJust (uus E.^. UserSupervisorCompany)
+          E.&&. (usrHasNotCmp UserSupervisorSupervisor E.||. usrHasNotCmp UserSupervisorUser)
+      -- E.where_ $ E.isJust (uus E.^. UserSupervisorCompany)                                      -- types, but yields incorrect result
+      --     E.&&.  E.notExists (do
+      --       uc <- E.from (
+      --             (do
+      --               uc <- E.from $ E.table @UserCompany
+      --               E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany
+      --                   E.&&.  uc E.^. UserCompanyUser    E.==. uus E.^. UserSupervisorUser
+      --               pure uc
+      --             ) `E.unionAll_` (do
+      --               uc <- E.from $ E.table @UserCompany
+      --               E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany
+      --                   E.&&.  uc E.^. UserCompanyUser    E.==. uus E.^. UserSupervisorSupervisor
+      --               pure uc
+      --             ))
+      --       E.where_ $ uc E.^. UserCompanyCompany E.=?. uus E.^. UserSupervisorCompany
+      --       )
+      return (uus, spr, sub)
+    dbtRowKey = queryRelation >>> (E.^. UserSupervisorId)
+    dbtProj = dbtProjId
+    dbtColonnade = formColonnade $ mconcat
+      [ dbSelect (applying _2) id (return . view (resultRelation . _entityKey))
+      , sortable (Just "reroute")     (i18nCell MsgTableRerouteActive)    $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
+      , sortable (Just "reason")      (i18nCell MsgUserSupervisorReason)  $ \(view $ resultRelation . _entityVal . _userSupervisorReason  -> r) -> maybeCell r textCell
+      , sortable (Just "cshort")      (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\
+      , sortable (Just "super")       (i18nCell MsgTableSupervisor)       $ \(view $ resultSupervisor  -> u) -> cellHasUserModal ForProfileDataR u
+      , sortable (Just "super-com")   (i18nCell MsgTableCompanies)        $ \(view $ resultSupervisor  . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
+          maybeMonoid <$> wgtCompanies True uid
+      , sortable (Just "subordinate") (i18nCell MsgTableSupervisee)       $ \(view $ resultSubordinate -> u) -> cellHasUserModal ForProfileDataR u
+      , sortable (Just "sub-company") (i18nCell MsgTableCompanies)        $ \(view $ resultSubordinate . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
+          maybeMonoid <$> wgtCompanies True uid
+      ]
+    validator = def -- validator = def & defaultSorting [ SortAscBy "cshort" ]
+    dbtSorting = Map.fromList
+      [ ("reason"       , SortColumn $ queryRelation    >>> (E.^. UserSupervisorReason))
+      , ("cshort"       , SortColumn $ queryRelation    >>> (E.^. UserSupervisorCompany))
+      , ("reroute"      , SortColumn $ queryRelation    >>> (E.^. UserSupervisorRerouteNotifications))
+      , ("super"        , SortColumn $ querySupervisor  >>> (E.^. UserDisplayName))
+      , ("subordinate"  , SortColumn $ querySubordinate >>> (E.^. UserDisplayName))
+      , ("super-comp"   , SortColumn (\row -> E.subSelect $ do
+            (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
+            E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySupervisor  row E.^. UserId
+            E.orderBy [E.asc $ cmp E.^. CompanyName]
+            return (cmp E.^. CompanyName)
+          ))
+      , ("user-company" , SortColumn (\row -> E.subSelect $ do
+            (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
+            E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySubordinate row E.^. UserId
+            E.orderBy [E.asc $ cmp E.^. CompanyName]
+            return (cmp E.^. CompanyName)
+          ))
+      ]
+    dbtFilter = mempty
+    dbtFilterUI = mempty
+    dbtParams = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Nothing
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormSubmit
+      , dbParamsFormAdditional =
+          let acts :: Map ActSupervision (AForm Handler ActSupervisionData)
+              acts = mconcat
+                      [ singletonMap ASChangeCompany $ pure ASChangeCompanyData
+                      ]
+          in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+
+    postprocess :: FormResult (First ActSupervisionData, DBFormResult UserSupervisorId Bool TblSupervisionData)
+                -> FormResult (      ActSupervisionData, Set UserSupervisorId)
+    postprocess inp = do
+        (First (Just act), jobMap) <- inp
+        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+        return (act, jobSet)
+
+
+getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html
+getFirmsSupervisionR = postFirmsSupervisionR
+postFirmsSupervisionR = do
+  (svRes, svTbl) <- runDB mkSupervisonTable
+  formResult svRes $ \case
+    (ASChangeCompanyData, relations) -> do
+      addMessage Info $ text2Html [st|Firmenwechsel Ansprechpartnerbeziehung noch nicht implementiert. #{Set.size relations} empfangen.|]
+      reloadKeepGetParams FirmsSupervisionR
+  -- TODO: Bug Firmenwechsel: Bestehende Ansprechpartnerbeziehung - Firma ändern!
+  let heading = MsgMenuFirmsSupervision
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    [whamlet|$newline never
+      <p>
+        In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene #
+        nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist:
+      <p>
+        ^{svTbl}
+    |]

src/Handler/Profile.hs

@@ -652,7 +652,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
       EL.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
       E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       return  (studyfeat, studydegree, studyterms)
-  companies <- wgtCompanies uid
+  companies <- wgtCompanies False uid
   -- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
   --     EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
   --     E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
@@ -1234,7 +1234,8 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..}
           E.&&. spr E.?. UserSupervisorUser       E.?=. E.val uid
         E.where_ $ usr E.^. UserId `E.in_` E.vals (entityKey <$> receivers)
         return (usr, spr)
-    dbtRowKey (usr `E.LeftOuterJoin` _) = usr E.^. UserId
+    --  dbtRowKey (usr `E.LeftOuterJoin` _) = usr E.^. UserId
+    dbtRowKey = (E.^. UserId) . queryReceiver
     dbtProj = dbtProjId
 
     dbtColonnade = mconcat
@@ -1265,7 +1266,7 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..}
                 rcmp = row ^? resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just . to unCompanyKey
                 errWgt fsh = let emsg = MsgCompanySupervisorCompanyMissing fsh
                              in [whamlet|^{messageTooltip =<< messageI Warning emsg} _{emsg}|]
-            cmps <- wgtCompanies' ruid
+            cmps <- wgtCompanies' True ruid
             return $ case (cmps, rcmp) of
               (Just (cwgt, cmpsData), Just svcsh)
                 | svcsh `notElem` (cmpsData ^.. traverse . _1) ->
@@ -1290,7 +1291,7 @@ mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..}
                   , sfsh `notElem` usrCmps -> companyIdCell sfid <> wgtCell (errWgt sfsh)
                   | otherwise ->              companyIdCell sfid
         ]
-    validator = def -- & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
+    validator = def & defaultSorting [ SortAscBy "user-name" ]
     dbtSorting = Map.fromList
         [ sortUserNameLink        queryReceiver
         -- , sortUserLetterEmailPin  queryReceiver
@@ -1474,7 +1475,7 @@ getUserRecipientsR uuid = do
             []                -> return Nothing -- no receivers
             [_] | usrReceives -> return Nothing -- only user receives for themself
             _ -> runDB $ do
-              usrCmps <- wgtCompanies' uid
+              usrCmps <- wgtCompanies' True uid
               let fshs :: [CompanyShorthand] = usrCmps ^.. _Just . _2 . traverse . _1
               rtbl <- mkReceiversTable uid fshs receivers
               return $ Just (rtbl, fst <$> usrCmps)

src/Handler/Users.hs

@@ -110,7 +110,7 @@ postUsersR = do
           (nameWidget userDisplayName userSurname)
       , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
       , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
-          maybeMonoid <$> wgtCompanies uid
+          maybeMonoid <$> wgtCompanies False uid
       -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant
       --     (AdminUserR <$> encrypt uid)
       --     (toWgt userCompanyPersonalNumber)

src/Handler/Utils/Company.hs

@@ -38,15 +38,15 @@ instance E.SqlString (Key Company)
 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
-wgtCompanies :: UserId -> DB (Maybe Widget)
+wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
-wgtCompanies = (wrapUL . fst <<$>>) . wgtCompanies'
+wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
   where
     wrapUL wgt = [whamlet|<ul .list--iconless>^{wgt}|]
 
 -- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
 --   NOTE: The widget must be wrapped with <ul>
-wgtCompanies' :: UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
+wgtCompanies' :: Bool -> UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
-wgtCompanies' uid = do
+wgtCompanies' useShort uid = do
     companies <- $(E.unValueN 4) <<$>> E.select do
       (usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
         `E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
@@ -68,7 +68,7 @@ wgtCompanies' uid = do
     procCmp _ [] = (0, [], [])
     procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
       let isTop  = cmpPrio >= maxPri
-          cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
+          cmpWgt = companyWidget' useShort isTop (cmpSh, cmpName, cmpSpr)
           (accPri,accTop,accRem) = procCmp maxPri cs
       in  ( max cmpPrio accPri
           , bool           accTop  (cmpWgt : accTop)    isTop -- lazy evaluation after repmin example, don't factor out the bool!

src/Handler/Utils/Widgets.hs

@@ -160,14 +160,17 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
 
 -- also see Handler.Utils.Table.Cells.companyCell
 companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
-companyWidget isPrimary (csh, cname, isSupervisor)
+companyWidget = companyWidget' False
+
+companyWidget'  :: Bool -> Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
+companyWidget' useShort isPrimary (csh, cname, isSupervisor)
   | isPrimary, isSupervisor = simpleLink (toWgt $ name <>                   iconSupervisor) curl
   | isPrimary               = simpleLink (toWgt   name                                    ) curl
   |            isSupervisor =             toWgt   name <> simpleLink (toWgt iconSupervisor) curl
   | otherwise               =             toWgt   name
   where
     curl = FirmUsersR csh
-    corg = ciOriginal cname
+    corg = ciOriginal $ bool cname csh useShort
     name
       | isSupervisor = text2markup (corg <> " ")
       | otherwise    = text2markup  corg