-- SPDX-FileCopyrightText: 2023-25 Steffen Jost <S.Jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS -Wno-unused-top-binds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
{-# LANGUAGE TypeApplications #-}

module Handler.Firm
  ( getFirmAllR   , postFirmAllR
  , getFirmUsersR , postFirmUsersR
  , getFirmSupersR, postFirmSupersR
  , getFirmCommR  , postFirmCommR
  , getFirmsCommR , postFirmsCommR
  , getFirmsSupervisionR , postFirmsSupervisionR
  )
  where

import Import

-- import Jobs
import Handler.Utils
import Handler.Utils.Company
import Handler.Utils.Communication
import Handler.Utils.Avs (guessAvsUser)

import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Csv as Csv
-- import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI
-- import qualified Data.Conduit.List as C
-- import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
import Database.Persist.Postgresql
import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
-- import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH


-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
-- 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


        -- prioLetterPassword :: E.SqlExpr (Entity User) -> SqlExpr (Value Int64)
        -- prioLetterPassword usr = E.case_ [E.when_ (usr E.^. UserPrefersPostal) E.then_ E.val ]


---------------------------------
-- General firm affecting actions

data FirmAction = FirmActNotify
                | FirmActResetSupervision
                | FirmActAddSupervisors
                | FirmActAddAssociates
                | 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
                        }
                    | FirmActAddSupervisorsData
                        { firmActAddUserIds                 :: Set Text
                        , firmActAddSupervisorReroute       :: Bool
                        , firmActAddSupervisorPostal        :: Maybe Bool
                        , firmActAddUserUseCompanyAddress   :: Bool
                        , firmActAddSupervisorReason        :: Maybe Text
                        }
                    | FirmActAddAssociatesData
                        { firmActAddUserIds                 :: Set Text
                        , firmActAddAssociatePriority       :: Int
                        , firmActAddUserUseCompanyAddress   :: Bool
                        , firmActAddAssociateReason         :: Maybe Text
                        }
                    | FirmActChangeContactFirmData
                        { firmActCCFPostalAddr              :: Maybe StoredMarkup
                        , firmActCCFEmail                   :: Maybe UserEmail
                        , firmActCCFPostalPref              :: Maybe Bool
                        , firmActCCFPinPassword             :: Maybe Bool
                        }
                    | FirmActChangeContactUserData
                        { firmActCCUPostalAddr              :: Maybe StoredMarkup
                        , firmActCCUUseCompanyPostal        :: Maybe Bool
                        , firmActCCUPostalPref              :: Maybe Bool
                        }
  deriving (Eq, Ord, Read, Show, Generic)

firmActionMap :: (_ -> Text) -> 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'                       (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 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 (SomeMsgs [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                  <*> aopt (emailField & cfStrip & cfCI)    (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip)        Nothing
                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFirmDefaultPreferenceInfo)   Nothing
                  <*> aopt boolField'                       (fslI MsgFormFieldPinPass & setTooltip MsgFirmDefaultPreferenceInfo)   Nothing
                  <*  aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
    mkAct _     FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
                  <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                  <*> aopt boolField'                       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
    mkAct _  _ = mempty
    ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
    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.&&.  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


firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing

makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts

firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
firmActionHandler route isAdmin = flip formResult faHandler
  where
    faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected

    faHandler (FirmActNotifyData, Set.toList -> fids) = do
      usrs <- runDBRead $ 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 (FirmActResetSupervisionData{..}, fids) = do
      madId <- bool maybeAuthId (return Nothing) isAdmin
      let suprFltr = if
            | isAdmin                 -> const E.true
            | (Just suprId) <- madId  -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId
            | otherwise               -> const E.false
      runDB $ do
        delSupers <- if firmActResetKeepOldSupers == Just False
          then E.deleteCount $ do
                spr <- E.from $ E.table @UserSupervisor
                E.where_ $ suprFltr spr
                    E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault)
                    E.&&. 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 <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
        addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
      reloadKeepGetParams route -- reload to reflect changes

    faHandler (FirmActAddSupervisorsData{..}, 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 MsgFirmActAddSupersEmpty
        reloadKeepGetParams route
      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 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
            , (CompanyEmail         =.) . Just <$> canonical firmActCCFEmail
            , (CompanyPrefersPostal =.)        <$>           firmActCCFPostalPref
            , (CompanyPinPassword   =.)        <$>           firmActCCFPinPassword
            ]
      in unless (null changes) $ do
        runDB $ update cid changes
        addMessageI Success MsgFirmActChangeContactFirmResult
        reloadKeepGetParams route

    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
      | firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
          addMessageI Error MsgCompanyUserUseCompanyPostalError
      | otherwise = do
          let changes = catMaybes
                [ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress   E.=. E.nothing)      -- precondition ensures that only one update applies for UserPostAddress
                , (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
                , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
                ]
          (total, nrChanged) <- runDB $ do
            nrUsrChange <- 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
            nrUseComp <- case firmActCCUUseCompanyPostal of
              Just x  -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
              Nothing -> return 0
            nrCid <- count [UserCompanyCompany ==. cid]
            return (fromIntegral nrCid, max nrUsrChange nrUseComp)
          let allok = bool Warning Success $ nrChanged == total
          addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
          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 isAdmin 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

-- repeatedly useful queries

usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
usrPrimaryCompanies cmp usr = do
  othr <- E.from $ E.table @UserCompany
  E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
      E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
      E.&&.  othr E.^. UserCompanyCompany  E.!=. cmp E.^. CompanyId                     -- redundant due to > above, but likely performance improving
  -- return othr

fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
fromUserCompany mbFltr cmpy = do
  usrCmpy <- E.from $ E.table @UserCompany
  let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
  E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr

firmCountUsers              :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsers              = E.subSelectCount . fromUserCompany Nothing

firmCountUsersPrimary       :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersPrimary cmp   = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
  where
    primFltr = E.notExists . usrPrimaryCompanies cmp

firmCountUsersSecondary     :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
  where
    primFltr =    E.exists . usrPrimaryCompanies cmp

firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors  = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
-- firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
--   usrCmpy <- E.from $ E.table @UserCompany
--   E.where_ $ (usrCmpy E.^. UserCompanyCompany    E.==. cmpy E.^. CompanyId)
--       E.&&.  (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
--   return $ usrCmpy E.^. UserCompanyUser

firmHasSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool)
firmHasSupervisors  = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor))


firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))

firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool)
firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))

firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr)
  where
    fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)
    fltr usrc = E.exists $ do
      usrSuper <- E.from $ E.table @UserSupervisor
      E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser

firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr)
  where
    fltr usrc = E.exists $ do
      usrSuper <- E.from $ E.table @UserSupervisor
      E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
        E.&&.    usrSuper E.^. UserSupervisorRerouteNotifications

firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr)
  where
    fltr usrc = E.exists $ do
      (usrSuper :& usr) <-
        E.from $ E.table @UserSupervisor
        `E.innerJoin` E.table @User
        `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
      E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser
        E.&&.    usrSuper E.^. UserSupervisorRerouteNotifications
        E.&&.              usr E.^. UserPrefersPostal
        E.&&.    E.isJust (usr E.^. UserPostAddress)


-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
--   [E.subSelect $ do
--     usrSuper <- E.from $ E.table @UserSupervisor
--     E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
--     E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
--       E.&&.  E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
--     return E.countRows
--   ] (E.val 0)

firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
    usrSuper <- E.from $ E.table @UserSupervisor
    E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
      E.&&.  E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
    pure $ usrSuper E.^. UserSupervisorSupervisor

-- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
--     usrSuper <- E.from $ E.table @UserSupervisor
--     E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
--       E.&&.  usrSuper E.^. UserSupervisorRerouteNotifications
--     pure $ usrSuper E.^. UserSupervisorSupervisor

firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes cmpy = E.subSelectCount $ do
    usrSuper <- E.from $ E.table @UserSupervisor
    E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
      E.&&.  usrSuper E.^. UserSupervisorRerouteNotifications

firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery ()
firmQuerySupervisedBy cid mbFltr usr = do
    (usrSpr :& usrCmp) <- E.from $  E.table @UserSupervisor
                      `E.innerJoin` E.table @UserCompany
                      `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
    let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
            E.&&.  usrCmp E.^. UserCompanyCompany       E.==. E.val cid
    E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr

firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64)
firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy

firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
firmCountUserSupervisors usrCmp = E.subSelectCount $ do
  usrSpr <- E.from $ E.table @UserSupervisor
  E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser

firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
  usrSpr <- E.from $ E.table @UserSupervisor
  E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
      E.&&.  usrSpr E.^. UserSupervisorRerouteNotifications


-----------------------
-- All Firms Table

-- just in case for future extensions
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
queryAllCompany = id

type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool, E.Value Word64)
resultAllCompanyEntity          :: Lens' AllCompanyTableData (Entity Company)
resultAllCompanyEntity          = _dbrOutput . _1

resultAllCompany                  :: Lens' AllCompanyTableData Company
resultAllCompany                  = resultAllCompanyEntity . _entityVal

resultAllCompanyUsers             :: Lens' AllCompanyTableData Word64
resultAllCompanyUsers             = _dbrOutput . _2 . _unValue

resultAllCompanySupervisors       :: Lens' AllCompanyTableData Bool
resultAllCompanySupervisors       = _dbrOutput . _3 . _unValue

resultAllCompanyDefaultReroutes   :: Lens' AllCompanyTableData Bool
resultAllCompanyDefaultReroutes   = _dbrOutput . _4 . _unValue

resultAllCompanyUsersSecondary    :: Lens' AllCompanyTableData Word64
resultAllCompanyUsersSecondary    = _dbrOutput . _5 . _unValue

mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
mkFirmAllTable isAdmin uid = do
  now <- liftIO getCurrentTime
  mr <- getMessageRender
  let
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery cmpy = 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.^. 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
                  , cmpy & firmHasDefaultReroutes               --  4
                  , cmpy & firmCountUsersSecondary              --  5
                  -- , cmpy & firmCountEmployeeSupervised
                  -- , cmpy & firmCountEmployeeRerouted
                  -- , cmpy & firmCountEmployeeRerPost
                  -- , cmpy & firmCountForeignSupervisors
                  -- , cmpy & firmCountActiveReroutes
                  -- , cmpy & firmCountActiveReroutes'
                  )
        dbtRowKey = (E.^. CompanyId)
        dbtProj = dbtProjId
        dbtColonnade = formColonnade $ mconcat
          [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
          , sortable (Just "name")          (i18nCell MsgTableCompany)                 $ \(view resultAllCompany -> firm) ->
              anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
          , sortable (Just "short")         (i18nCell MsgTableCompanyShort)            $ \(view resultAllCompany -> firm) ->
              let fsh = companyShorthand firm
              in  anchorCell (FirmSupersR fsh) $ toWgt fsh
          , sortable (Just "avsnr")         (i18nCell MsgTableCompanyNo)               $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm
          , sortable (Just "users")         (i18nCell MsgTableCompanyNrUsers)          $ \(view resultAllCompanyUsers               -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "secondary")     (i18nCell MsgTableCompanyNrSecondaryUsers) $ \(view resultAllCompanyUsersSecondary      -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "supervisors")   (i18nCell MsgTableCompanyNrSupersDefault)  $ \row ->
              anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
          , sortable (Just "reroute-def")   (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes     -> ok) -> tickmarkCell ok
          -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised)  $ \(view resultAllCompanyEmployeeSupervised  -> nr) -> wgtCell $ word2widget nr
          -- , sortable (Just "emp-rerouted")  (i18nCell MsgTableCompanyNrEmpRerouted)    $ \(view resultAllCompanyEmployeeRerouted    -> nr) -> wgtCell $ word2widget nr
          -- , sortable (Just "emp-rer-post")  (i18nCell MsgTableCompanyNrEmpRerPost)     $ \(view resultAllCompanyEmpRerPost          -> nr) -> wgtCell $ word2widget nr
          -- , sortable (Just "foreigners")    (i18nCell MsgTableCompanyNrForeignSupers)  $ \(view resultAllCompanyForeignSupers       -> nr) -> wgtCell $ word2widget nr
          -- , sortable (Just "reroute-act")   (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultAllCompanyActiveReroutes      -> nr) -> wgtCell $ word2widget nr
          -- , sortable (Just "reroute-all")   (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultAllCompanyActiveReroutes'     -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "postal-pref")   (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
          , sortable (Just "pin-password")  (i18nCell MsgTableCompanyPinPassword)      $ \(view $ resultAllCompany . _companyPinPassword   -> b) -> ifIconCell b IconPinProtect & addIconFixedWidth
          ]
        dbtSorting = mconcat
          [ singletonMap "name"           $ SortColumn (E.^. CompanyName)
          , singletonMap "short"          $ SortColumn (E.^. CompanyShorthand)
          , singletonMap "avsnr"          $ SortColumn (E.^. CompanyAvsId)
          , singletonMap "postal-pref"    $ SortColumn (E.^. CompanyPrefersPostal)
          , singletonMap "pin-password"   $ SortColumn (E.^. CompanyPinPassword)
          , singletonMap "users"          $ SortColumn firmCountUsers
          , singletonMap "secondary"      $ SortColumn firmCountUsersSecondary
          , singletonMap "supervisors"    $ SortColumn firmHasSupervisors
          -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
          -- , singletonMap "emp-rerouted"   $ SortColumn firmCountEmployeeRerouted
          -- , singletonMap "emp-rer-post"   $ SortColumn firmCountEmployeeRerPost
          , singletonMap "reroute-def"    $ SortColumn firmHasDefaultReroutes
          -- , singletonMap "foreigners"     $ SortColumn firmCountForeignSupervisors
          -- , singletonMap "reroute-act"    $ SortColumn firmCountActiveReroutes
          -- , singletonMap "reroute-all"    $ SortColumn firmCountActiveReroutes'
          ]
        dbtFilter = Map.fromList
          [ fltrCompanyNameNr queryAllCompany
          , ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId)))
          , ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
              (usr :& usrCmp) <- E.from $ E.table @User
                `E.innerJoin` E.table @UserCompany
                `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
              E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
                E.&&. (  (usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
                  E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
                  E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
                )
            )
          -- THIS WAS WAY TOO SLOW:
          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
          --     (usr :& usrCmp) <- E.from $ E.table @User
          --       `E.leftJoin` E.table @UserCompany
          --       `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
          --     E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
          --           E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
          --           E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
          --       ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId)
          --           E.||. E.exists (do
          --               usrSpr <- E.from $ E.table @UserSupervisor
          --               E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
          --                 E.&&. E.exists (do
          --                     usrSub <- E.from $ E.table @UserCompany
          --                     E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
          --                         E.&&.  usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
          --                   )
          --             )
          --       )
          --   )
          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
          --     usr <- E.from $ E.table @User
          --     E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
          --           E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
          --           -- E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
          --       ) E.&&. (E.exists (do
          --             usrCmp <- E.from $ E.table @UserCompany
          --             E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
          --               E.&&. usrCmp E.^. UserCompanySupervisor
          --               E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
          --           ) E.||. E.exists (do
          --             usrSpr <- E.from $ E.table @UserSupervisor
          --             E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
          --               E.&&. E.exists (do
          --                   usrSub <- E.from $ E.table @UserCompany
          --                   E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
          --                       E.&&.  usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
          --                 )
          --           )
          --       )
          --   )
          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
          --     usr <- E.from $ E.table @User
          --     E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
          --           E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
          --           -- E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
          --       ) E.&&. E.exists (do
          --             usrCmp <- E.from $ E.table @UserCompany
          --             E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
          --               E.&&. (( usrCmp E.^. UserCompanySupervisor
          --                 E.&&.  usrCmp E.^. UserCompanyUser              E.==. usr E.^. UserId
          --               ) E.||. E.exists (do
          --                 usrSpr <- E.from $ E.table @UserSupervisor
          --                 E.where_ $ usrSpr E.^. UserSupervisorUser       E.==. usrCmp E.^. UserCompanyUser
          --                     E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
          --               ))
          --       )
          --   )
          -- , ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
          --     case criterion of
          --       Nothing -> E.true
          --       (Just (crit::Text)) -> E.exists $ do
          --             usr <- E.from $ E.table @User
          --             E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val crit)
          --                   E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
          --                   E.||. (usr E.^. UserSurname      `E.hasInfix` E.val crit)
          --               ) E.&&. E.exists (do
          --                     usrCmp <- E.from $ E.table @UserCompany
          --                     E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
          --                       E.&&. (( usrCmp E.^. UserCompanySupervisor
          --                         E.&&.  usrCmp E.^. UserCompanyUser              E.==. usr E.^. UserId
          --                       ) E.||. E.exists (do
          --                         usrSpr <- E.from $ E.table @UserSupervisor
          --                         E.where_ $ usrSpr E.^. UserSupervisorUser       E.==. usrCmp E.^. UserCompanyUser
          --                             E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
          --                       ))
          --               )
          --   )
          -- , ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- did not work as intended
          --     case criterion of
          --       Nothing -> return True :: DB Bool
          --       (Just (crit::Text)) -> do
          --         critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:" <> crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do
          --           (usr :& cmp) <- E.from  $ E.table @User `E.innerJoin` E.table @Company
          --             `E.on` (\(usr :& cmp) -> E.exists (do
          --               usrCmp <- E.from $ E.table @UserCompany
          --               E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
          --                 E.&&. usrCmp E.^. UserCompanySupervisor
          --                 E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
          --             ) E.||. E.exists (do
          --               usrSpr <- E.from $ E.table @UserSupervisor
          --               E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
          --                 E.&&. E.exists (do
          --                   usrSub <- E.from $ E.table @UserCompany
          --                   E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
          --                       E.&&.  usrSub E.^. UserCompanyCompany E.==. cmp    E.^. CompanyId
          --                 )
          --             ))
          --           E.where_ $ (usr E.^. UserDisplayName  `E.hasInfix` E.val        crit )
          --               E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
          --               E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val        crit )
          --           -- E.orderBy [E.asc $ cmp E.^. CompanyId]
          --           return $ cmp E.^. CompanyId
          --         let cid = dbr ^. resultAllCompanyEntity . _entityKey
          --         return $ Set.member cid critFirms
          --   )
          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  -- too slow
          --     (usr :& usrCmp) <- E.from $ E.table @User
          --       `E.leftJoin` E.table @UserCompany
          --       `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
          --     E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
          --           E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
          --           E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
          --       ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId)
          --           E.||. E.exists (do
          --               (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==.  usrSub E.^. UserCompanyUser)
          --               E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
          --                 E.&&.    usrSub E.^. UserCompanyCompany       E.==. queryAllCompany row E.^. CompanyId
          --             )
          --       )
          --   )
          , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
              (usr :& _usrSpr :& usrCmp) <- E.from $ E.table @User
                `E.innerJoin` E.table @UserSupervisor `E.on` (\(usr :& usrSpr          ) -> usr    E.^. UserId          E.==. usrSpr E.^. UserSupervisorSupervisor)
                `E.innerJoin` E.table @UserCompany    `E.on` (\(_   :& usrSpr :& usrCmp) -> usrCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser)
              E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
                    E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
                    E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
                ) E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
            )
          , ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
              (usr :& usrCmp) <- E.from $ E.table @User
                `E.innerJoin` E.table @UserCompany
                `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
              E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
                    E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
                    E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
                ) E.&&. usrCmp E.^. UserCompanySupervisor
                  E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
            )
          , ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
              -- let checkSuper = do -- expensive
              --       usrSpr <- E.from $ E.table @UserSupervisor
              --       E.where_ $ E.notExists (do
              --           spr <- E.from $  E.table @UserCompany
              --           E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
              --             E.&&.    spr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorSupervisor
              --         ) E.&&. E.exists (do
              --           usr <- E.from $  E.table @UserCompany
              --           E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
              --             E.&&.    usr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
              --         )
              let checkSuper = do
                    usr <- E.from $ E.table @UserCompany
                    E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
                        E.&&. E.exists (do
                          usrSpr <- E.from $ E.table @UserSupervisor
                          E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
                              E.&&. E.notExists (do
                                sprCmp <- E.from $ E.table @UserCompany
                                E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
                                    E.&&.  sprCmp E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorSupervisor
                              )
                        )
              in case criterion of
                Nothing    -> E.true
                Just True  -> E.exists    checkSuper
                Just False -> E.notExists checkSuper
            )
          , ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
          , ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
              (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany
                `E.innerJoin` E.table @QualificationUser
                `E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser)
                `E.innerJoin` E.table @Qualification
                `E.on` (\(_ :& usrQual :& qual) -> qual E.^. QualificationId E.==. usrQual E.^. QualificationUserQualification)
              E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
                E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
                E.&&. validQualification now usrQual
            )
          , ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress)))
          ]
        dbtFilterUI mPrev = mconcat
          [ fltrCompanyNameUI mPrev
          , prismAForm (singletonFilter "company-number")                             mPrev $ aopt textField (fslI MsgTableCompanyNo)
          , prismAForm (singletonFilter "is-associate")                               mPrev $ aopt textField (fslI MsgTableCompanyUser)
          -- , prismAForm (singletonFilter "is-supervisor0")                             mPrev $ aopt textField (fslI MsgTableSupervisor)
          , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisorActive)
          , prismAForm (singletonFilter "is-default-supervisor")                      mPrev $ aopt textField (fslI MsgFirmSuperDefault)
          , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
          , prismAForm (singletonFilter "company-address")                            mPrev $ aopt textField (fslI MsgFirmAddress)
          , fltrQualificationHdrUI MsgFilterHasQualification mPrev
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Nothing
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision]
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
        dbtIdent :: Text
        dbtIdent = "firm"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []

    postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData)
                -> 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 FirmActionData, DBFormResult CompanyId Bool FirmActionData))
    resultDBTableValidator = def
      & defaultSorting  [SortAscBy "short"]
  over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable


getFirmAllR, postFirmAllR :: Handler Html
getFirmAllR = postFirmAllR
postFirmAllR = do
  uid <- requireAuthId
  isAdmin <- checkAdmin
  (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
  firmActionHandler FirmAllR isAdmin firmRes
  siteLayoutMsg MsgMenuFirms $ do
    setTitleI MsgMenuFirms
    $(i18nWidgetFile "firm-all")


-----------------------
-- Firm Users Table


data FirmUserAction = FirmUserActNotify
                    | FirmUserActResetSupervision
                    | FirmUserActSetSupervisor
                    | FirmUserActMkSuper
                    | FirmUserActChangeDetails
                    | FirmUserActChangeContact
                    | FirmUserActRemove
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmUserAction id

data FirmUserActionData = FirmUserActNotifyData
                        | FirmUserActResetSupervisionData
                            { firmUserActResetSupers            :: Maybe Bool
                            }
                        | FirmUserActSetSupervisorData
                            { firmUserActSetSuperNames          :: Maybe (Set Text)
                            , firmUserActSetSuperIds            :: Maybe [UserId]
                            , firmUserActSetSuperReason         :: Maybe Text
                            , firmUserActSetSuperReroute        :: Bool
                            , firmUserActResetSupers            :: Maybe Bool
                            }
                        | FirmUserActMkSuperData
                            { firmUserActMkSuperReroute         :: Maybe Bool }
                        | FirmUserActChangeDetailsData
                            { firmUserActDetailPriority         :: Maybe Int
                            , firmUserActDetailReason           :: Maybe Text
                            }
                        | FirmUserActChangeContactData
                            { firmUserActPostalAddr             :: Maybe StoredMarkup
                            , firmUserActUseCompanyPostal       :: Maybe Bool
                            , firmUserActPostalPref             :: Maybe Bool
                            , firmUserActPinPassword            :: Bool
                            }
                        | FirmUserActRemoveData
                            { firmUserActRemoveSupers           :: Bool
                            }
  deriving (Eq, Ord, Show, Generic)

type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)

queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User)
queryUserUser = $(sqlIJproj 2 1)

queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
queryUserUserCompany = $(sqlIJproj 2 2)

type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)

resultUserUser :: Lens' UserCompanyTableData (Entity User)
resultUserUser = _dbrOutput . _1

resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany)
resultUserUserCompany = _dbrOutput . _2

resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64
resultUserCompanySupervisors = _dbrOutput . _3 . _unValue

resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue

resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
resultUserCompanyPrimary = _dbrOutput . _5 . _unValue

instance HasEntity UserCompanyTableData User where
  hasEntity = resultUserUser

instance HasUser UserCompanyTableData where
  hasUser = resultUserUser . _entityVal


mkFirmUserTable :: Bool -> Entity Company -> DB (FormResult (FirmUserActionData, Set UserId), Widget)
mkFirmUserTable isAdmin Entity{entityKey=cid, entityVal=compData} = do
  mr <- getMessageRender
  let
    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
      uuid <- toPathPiece <$> encryptUser uid
      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)

    procOptions rawSupers = do
      procSupers <- traverse mkSprOption rawSupers
      return $ mkOptionListGrouped $ filter (notNull . snd)
             [ (mr MsgTableSuperior     , [opt | (opt, _         , True ) <- procSupers])
             , (mr MsgFirmSuperDefault  , [opt | (opt, Just True , False) <- procSupers])
             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   , False) <- procSupers])
             ]

  rawSupers <- E.select $ do
    (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
            `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
    E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
        E.||.  (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
        E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason)
  let
    -- supervisorField :: Field Handler UserId
    -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
    supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers

    fsh = unCompanyKey cid
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
          EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
          E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
          let isPrimary = E.notExists (do
                  other <- E.from $ E.table @UserCompany
                  E.where_ $ other E.^. UserCompanyUser     E.==. usrCmp E.^. UserCompanyUser
                      E.&&.  other E.^. UserCompanyPriority E.>.  usrCmp E.^. UserCompanyPriority
                  )
          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
        dbtRowKey = queryUserUser >>> (E.^. UserId)
        dbtProj = dbtProjId
        dbtColonnade = formColonnade $ mconcat
          [ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
          , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
          , guardMonoid isAdmin $ sortable (Just "matriculation")   (i18nCell MsgTableMatrikelNr)              $ \(view resultUserUser           -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr
          , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber)        $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
          , sortable (Just "supervisors")     (i18nCell MsgTableCompanyNrSupers       )  $ \(view   resultUserCompanySupervisors  -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "reroutes")        (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view   resultUserCompanyReroutes     -> nr) -> wgtCell $ word2widget nr
          , colUserLetterEmailPin
          , sortable Nothing                  (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
              let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
                  useCompA  = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
              in tickmarkCell $ noUsrAddr && useCompA
          , colUserEmail
          , sortable (Just "usr-reason")      (i18nCell MsgTableCompanyReason)           $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
          , sortable (Just "priority")        (i18nCell MsgCompanyUserPriority)          $ \row ->
              let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
                  isPrime     = row ^. resultUserCompanyPrimary
              in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
          , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
          ]

        dbtSorting = Map.fromList
          [ sortUserNameLink        queryUserUser
          , sortUserEmail           queryUserUser
          , sortUserLetterEmailPin  queryUserUser
          , ("matriculation"    , SortColumn $ queryUserUser        >>> (E.^. UserMatrikelnummer)       )
          , ("personal-number"  , SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber))
          , ("supervisors"      , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors        )
          , ("reroutes"         , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute )
          , ("usr-reason"       , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)        )
          , ("priority"         , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)      )
          ]
        dbtFilter = Map.fromList
          [ fltrUserNameEmail queryUserUser
          , ("has-supervisor", FilterColumn $ \row (getLast -> criterion) ->
              let checkSuper = do
                    usrSpr <- E.from $ E.table @UserSupervisor
                    E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
              in case criterion of
                  Nothing     -> E.true
                  Just True   -> E.exists    checkSuper
                  Just False  -> E.notExists checkSuper
            )
          , ("has-company-supervisor", FilterColumn $ \row (getLast -> criterion) ->
              let checkSuper = do
                    usrSpr <- E.from $ E.table @UserSupervisor
                    E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                        E.&&.  E.exists (do
                                  spr <- E.from $  E.table @UserCompany
                                  E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
                                    E.&&.    spr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorSupervisor
                                )
              in case criterion of
                  Nothing     -> E.true
                  Just True   -> E.exists    checkSuper
                  Just False  -> E.notExists checkSuper
            )
          , ("has-foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
              let checkSuper = do
                    usrSpr <- E.from $ E.table @UserSupervisor
                    E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                        E.&&.  E.notExists (do
                                  spr <- E.from $  E.table @UserCompany
                                  E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
                                    E.&&.    spr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorSupervisor
                                )
              in case criterion of
                  Nothing     -> E.true
                  Just True   -> E.exists    checkSuper
                  Just False  -> E.notExists checkSuper
            )
          , ("supervisor-is", FilterColumn $ \row (getLast -> criterion) ->
              case criterion of
                Just uid -> do
                  -- uid <- decryptUser uuid
                  E.exists $ do
                    usrSpr <- E.from $ E.table @UserSupervisor
                    E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                        E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
                _otherwise -> E.true
            )
          , ("supervisors-are", FilterColumn $ \row criteria ->
              case criteria of
                _ | Set.null criteria -> E.true
                  | otherwise -> do
                      -- uids <- traverse decryptUser criteria
                      E.exists $ do
                        usrSpr <- E.from $ E.table @UserSupervisor
                        E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                            E.&&.  usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
            )
          , ("is-primary-company", FilterColumn $ \row (getLast -> criterion) ->
              let checkPrimary = do
                    other <- E.from $ E.table @UserCompany
                    E.where_ $ other E.^. UserCompanyUser     E.==. queryUserUserCompany row E.^. UserCompanyUser
                        E.&&.  other E.^. UserCompanyPriority E.>.  queryUserUserCompany row E.^. UserCompanyPriority
              in case criterion of
                  Nothing     -> E.true
                  Just False  -> E.exists    checkPrimary
                  Just True   -> E.notExists checkPrimary
            )
          ]
        -- superField = selectField $ ????
        dbtFilterUI mPrev = mconcat
          [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
          -- , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece)     mPrev $ aopt (hoistField lift supervisorField)  (fslI MsgFilterSupervisor)
          , prismAForm (multiFilter     "supervisors-are"        . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip)
          , 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)
          , prismAForm (singletonFilter "is-primary-company"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI   MsgFilterFirmPrimary)
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        userReasons :: HandlerFor UniWorX (OptionList Text)
        userReasons = 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.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
            return $ usrc E.^. UserCompanyReason
        superReasons :: HandlerFor UniWorX (OptionList Text)
        superReasons = 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 @UserSupervisor
            E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
                  E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
            return $ usrc E.^. UserSupervisorReason
        acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
        acts = mconcat
          [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
          , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
              <$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
          , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
              <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
              <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)         Nothing
              <*> areq  boolField'                                        (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
              <*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
          , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
              <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
          , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
              <$> aopt htmlField        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
              <*> aopt boolField'       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
              <*> aopt postalEmailField (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
              <*> if companyPinPassword compData then pure False else
                  areq boolField' (fslI MsgFormFieldPinPassRemove) Nothing
          , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
          , singletonMap FirmUserActRemove $ FirmUserActRemoveData
              <$> areq boolField'       (fslI MsgFirmActRemoveSupers) (Just True)
          ]
        dbtParams = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Nothing
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard $ (, mempty) . First . Just
                  <$> multiActionA acts (fslI MsgTableAction) Nothing
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
        dbtIdent :: Text
        dbtIdent = "firm-users"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []

    postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData)
                -> FormResult (      FirmUserActionData, Set UserId)
    postprocess inp = do
        (First (Just act), m) <- inp
        let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
        return (act, s)

    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData))
    resultDBTableValidator = def
      & defaultSorting  [SortAscBy "user-name"]
  over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable


getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
getFirmUsersR  = postFirmUsersR
postFirmUsersR fsh = do
  isAdmin <- checkAdmin
  let cid = CompanyKey fsh
  ((    Entity{entityVal=Company{..}}
      , E.Value nrCompanyUsers
      , E.Value nrCompanySupervisors
      , E.Value nrCompanyForeignSupers
      , E.Value nrCompanyEmployeeSupervised
      , E.Value nrCompanyEmployeeRerouted
      , E.Value nrCompanyEmployeeRerPost
      , E.Value nrCompanyDefaultReroutes
      , E.Value nrCompanyActiveReroutes
   )  , (fusrRes, fusrTable)) <- runDB $ do
      compEnt <- fromMaybeM notFound (E.selectOne $ do
          cmpy <- E.from $ E.table @Company
          E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
          return  ( cmpy
                  , cmpy & firmCountUsers
                  , cmpy & firmCountSupervisors
                  , cmpy & firmCountForeignSupervisors
                  , cmpy & firmCountEmployeeSupervised
                  , cmpy & firmCountEmployeeRerouted
                  , cmpy & firmCountEmployeeRerPost
                  , cmpy & firmCountDefaultReroutes
                  , cmpy & firmCountActiveReroutes
                  ))
      -- superVs <- E.select $ do
      --     usr <- E.from $ E.table @User
      --     E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
      --     return usr
      tbl <- mkFirmUserTable isAdmin (compEnt ^. _1)
      return (compEnt, tbl)

  let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
      resetSupers Nothing      _    = return 0
      resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
      resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
  formResult fusrRes $ \case
    (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
    (FirmUserActNotifyData , uids) -> do
      cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
      redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
    (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do  -- set guaranteed to be non-empty due to first case clause
      runDB $ do
        delSupers <- resetSupers firmUserActResetSupers uids
        newSupers <- addDefaultSupervisors Nothing cid uids
        addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
      avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames
      let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
          usersFound = mapMaybe snd usersFound'
          newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound
          nrSupers = fromIntegral $ length newSupers
          nrUsers  = fromIntegral $ length uids
      unless (null usersNotFound) $
        let msgContent = [whamlet|
              $newline never
              <ul>
                $forall (usr,_) <- usersNotFound
                  <li>#{usr}
              |]
        in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
      delSupers <- runDB $ resetSupers firmUserActResetSupers uids
        <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
      addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
      addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
      let upReason = case canonical firmUserActDetailReason of
                      Nothing     -> Nothing
                      Just "NULL" -> Just $ UserCompanyReason =. Nothing
                      other       -> Just $ UserCompanyReason =. other
      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
      let total = fromIntegral $ length uids
          allok = bool Warning Success $ nrUpd == total
      addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmUserActChangeContactData{..}, Set.toList -> uids)
      | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
          addMessageI Error MsgCompanyUserUseCompanyPostalError
      | otherwise -> do
        let changes =
              bcons (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) $     -- precondition ensures that only one update applies for UserPostAddress
              bcons  firmUserActPinPassword                    (UserPinPassword =. Nothing) $ catMaybes
              [ (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr                 -- note that Nothing means no change and not delete address!
              , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
              ]
        nrChanged <- runDB $ do
          nrUsrChange <- updateWhereCount [UserId <-. uids] changes
          nrUseComp   <- case firmUserActUseCompanyPostal of
            Just x  -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
            Nothing -> return 0
          return $ max nrUsrChange nrUseComp
        let total = fromIntegral $ length uids
            allok = bool Warning Success $ nrChanged == total
        addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
        reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmUserActRemoveData{..}, Set.toList -> uids) -> do
      let optRemove = if firmUserActRemoveSupers then id else const $ return 0
      (nrUc, nrSuper, nrSubs) <- runDB $ (,,)
        <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
      let total = fromIntegral $ length uids
          allok = bool Warning Success $ total == nrUc
      addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes

  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddAssociates, FirmActChangeContactFirm, FirmActChangeContactUser]

  siteLayout (citext2widget companyName) $ do
    setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
    let firmContactInfo = $(widgetFile "firm-contact-info")
    $(widgetFile "firm-users")


-----------------------------
-- Firm Supervisors Table

data FirmSuperAction = FirmSuperActNotify
                     | FirmSuperActSwitchSuper
                     | FirmSuperActRMSuperDef

  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmSuperAction id

data FirmSuperActionData = FirmSuperActNotifyData
                         | FirmSuperActSwitchSuperData
                            { firmSuperActSwitchSuper   :: Maybe Bool
                            , firmSuperActSwitchReroute :: Maybe Bool
                            }
                         | FirmSuperActRMSuperDefData
                            { firmSuperActRMSuperActive ::       Bool }

  deriving (Eq, Ord, Show, Generic)


type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany))

querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
querySuperUser = $(sqlLOJproj 2 1)

querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany))
querySuperUserCompany = $(sqlLOJproj 2 2)

type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
                                    , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
                                    , E.Value (Maybe Bool), E.Value (Maybe Bool)   -- Maybe (Entity UserCompany)
                                    , E.Value Bool
                                    )

resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
resultSuperUser = _dbrOutput . _1

resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64
resultSuperCompanySupervised = _dbrOutput . _2 . _unValue

resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64
resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue

resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
resultSuperCompanies = _dbrOutput . _4

resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool)
resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue

resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue

resultSuperCompanySuperior :: Lens' SuperCompanyTableData Bool
resultSuperCompanySuperior = _dbrOutput . _7 . _unValue

instance HasEntity SuperCompanyTableData User where
  hasEntity = resultSuperUser

instance HasUser SuperCompanyTableData where
  hasUser = resultSuperUser . _entityVal


mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
mkFirmSuperTable isAdmin cid = do
  msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
  let
    reasonSuperior = tshow SupervisorReasonAvsSuperior
    -- fsh = unCompanyKey cid
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
          EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
          E.where_ $  E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
          -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
          return ( usr
                 , usr & firmCountForSupervisor cid Nothing
                 , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
                 , usrCmp E.?. UserCompanySupervisor
                 , usrCmp E.?. UserCompanySupervisorReroute
                 -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
                 , (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well
                    E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr)
                 )
        dbtRowKey = querySuperUser >>> (E.^. UserId)
        dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
            cmps <- E.select $ 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.==. E.val (entityKey usr)
              E.orderBy [E.asc $ cmp E.^. CompanyName]
              return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
            return (usr, supervised, rerouted, cmps, supervisor, reroute, isSuperior)
        dbtColonnade = formColonnade $ mconcat
          [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
          , colUserNameModalHdr MsgTableSupervisor ForProfileDataR
          , guardMonoid isAdmin $ sortable (Just "matriculation")   (i18nCell MsgTableMatrikelNr)              $ \(view   resultSuperUser                         -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr
          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) ->
              intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps]
          , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber)        $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
          , colUserLetterEmailPin
          , colUserEmail
          , sortable (Just "supervised")  (i18nCell MsgTableCompanyNrEmpSupervised)  $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "rerouted")    (i18nCell MsgTableCompanyNrEmpRerouted  )  $ \(view resultSuperCompanyReroutes   -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case
              Nothing      -> iconCell IconSupervisorForeign
              (Just True ) -> iconCell IconSupervisor
              (Just False) -> iconSpacerCell
          , sortable Nothing  (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
          , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute)    $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
          , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
          ]
        dbtSorting = Map.fromList
          [ sortUserNameLink                   querySuperUser
          , sortUserEmail                      querySuperUser
          , sortUserLetterEmailPin             querySuperUser
          , ("matriculation"    , SortColumn $ querySuperUser        >>> (E.^. UserMatrikelnummer))
          , ("personal-number"  , SortColumn $ querySuperUser        >>> (E.^. UserCompanyPersonalNumber))
          , ("supervised"       , SortColumn $ querySuperUser        >>> firmCountForSupervisor cid Nothing)
          , ("rerouted"         , SortColumn $ querySuperUser        >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)))
          , ("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.==. querySuperUser row E.^. UserId
              E.orderBy [E.asc $ cmp E.^. CompanyName]
              return (cmp E.^. CompanyName)
            ))
          , ("def-super"        , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor))
          , ("def-reroute"      , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute))
          ]
        dbtFilter = Map.fromList
          [ fltrUserNameEmail querySuperUser
          , ("is-foreign-supervisor", FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
              case criterion of
                  Nothing     -> E.true
                  Just True   -> E.isNothing $ suc E.?. UserCompanyUser
                  Just False  -> E.isJust    $ suc E.?. UserCompanyUser
            )
          , ("super-relation-foreign", FilterColumn $ \row (getLast -> criterion) ->
              let checkSuper = do
                    usrSpr <- E.from $ E.table @UserSupervisor
                    E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
                        E.&&.  E.exists (do
                                  usr <- E.from $  E.table @UserCompany
                                  E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
                                    E.&&.    usr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
                                )
              in case criterion of
                  Nothing     -> E.true
                  Just True   -> E.exists    checkSuper
                  Just False  -> E.notExists checkSuper
            )
          ]
        dbtFilterUI mPrev = mconcat
          [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
          , prismAForm (singletonFilter "is-foreign-supervisor"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
          , prismAForm (singletonFilter "super-relation-foreign"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
        acts = mconcat
          [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
          , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
              <$> aopt boolField' (fslI MsgFirmSuperDefault)  (Just $ Just True)
              <*> aopt boolField' (fslI MsgTableIsDefaultReroute)      Nothing
              <*  aformMessage msgSupervisorUnchanged
          , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
              <$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
          ]
        dbtParams = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Nothing
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard $ (, mempty) . First . Just
                  <$> multiActionA acts (fslI MsgTableAction) Nothing
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
        dbtIdent :: Text
        dbtIdent = "firm-supervisors"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []

    postprocess :: FormResult (First FirmSuperActionData, DBFormResult UserId Bool SuperCompanyTableData)
                -> FormResult (      FirmSuperActionData, Set UserId)
    postprocess inp = do
        (First (Just act), m) <- inp
        let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
        return (act, s)

    resultDBTableValidator = def
      & defaultSorting  [SortAscBy "user-name"]
  over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable


getFirmSupersR, postFirmSupersR :: CompanyShorthand ->  Handler Html
getFirmSupersR = postFirmSupersR
postFirmSupersR fsh = do
  isAdmin <- checkAdmin
  let cid = CompanyKey fsh
  (Company{..},(fsprRes,fsprTable)) <- runDB $ (,)
    <$> get404 cid
    <*> mkFirmSuperTable isAdmin cid

  formResult fsprRes $ \case
    (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
    (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
      let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
      (nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
        <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
      let total = fromIntegral $ length uids
          allok = bool Warning Success $ total == nrRmSuper
      addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
      let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
            (Just True, Nothing)  -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ])
            (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer]
                                                                       , [UserCompanySupervisor =. True ,        UserCompanySupervisorReroute =. rer  ])
            (Just False, _)       -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False,        UserCompanySupervisorReroute =. False])
            (Nothing, Just True)  -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ])
            (Nothing, Just False) -> ([                                UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False])
            (Nothing, Nothing   ) -> ([],[])
      nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes
      addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing
      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
    (FirmSuperActNotifyData    , uids) -> do
      cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
      redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])

  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]

  siteLayout (citext2widget companyName) $ 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]


getFirmsCommR,  postFirmsCommR :: Companies -> Handler Html
getFirmsCommR = postFirmsCommR
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR)


handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
handleFirmCommR _       [] = invalidArgs ["At least one company name must be provided."]
handleFirmCommR ultDest cs = do
  let
    queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds
    queryGiven usrs = do
      usr <- E.from $ E.table @User
      E.where_ $ usr E.^. UserId `E.in_` E.valList usrs
      return usr
    mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId]
    mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l]
    toGrp  = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey)
    csKeys = CompanyKey <$> cs
  mbUser <- maybeAuthId
  -- get employees of chosen companies
  empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
      (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
      E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
      E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
      return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
    )
  -- get supervisors of employees
  sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
      (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
      E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
        E.||. (spr E.^. UserId E.=?. E.val mbUser)
        E.||. E.exists (do
          usrSpr <- E.from $ E.table @UserSupervisor
          E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
              E.&&.  usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys)
        )
      E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany]
      return (cmp E.?. UserCompanyCompany, spr E.^. UserId)
    )

  commR CommunicationRoute
    { crHeading   = SomeMessage $ case cs of { [c] -> MsgFirmNotification      c ; _ -> MsgFirmsNotification }
    , crTitle     = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle }
    , crUltDest   = ultDest
    , crJobs      = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
    , crTestJobs  = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
    , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
    , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
      [(toGrp acid, queryGiven usrs) | (acid, usrs)  <- Map.toAscList sprs ] ++
      [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs)  | (Just acid, usrs) <- Map.toAscList empys ]
    }

  {- Auswahlbox für Mitteilung:
    Wenn Firma gewählt, dann zeige:
      Alle Supervisor von Leuten in X, gruppiert nach deren Firma
      Alle Teilnehmer von X
    Wenn keine Firma gewählt, dann zeige:
      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}
    |]