-- SPDX-FileCopyrightText: 2022-2025 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE BlockArguments #-}         -- do starts is own block
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Utils.Company where


import Import

-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
-- import qualified Data.Char as Char
-- import qualified Data.Text as Text
import Database.Persist.Postgresql

import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils        as E
import qualified Database.Esqueleto.PostgreSQL   as E

import Handler.Utils.Users
import Handler.Utils.Widgets

-- KeyCompany is CompanyShorthand, i.e. CI Text
instance E.SqlString (Key Company)

-- Snippet to restrict to primary company only
--  E.&&. E.notExists (do
--      othr <- E.from $ E.table @UserCompany
--      E.where_ $ othr E.^. UserCompanyPriority E.>.  userCompany E.^. UserCompanyPriority
--          E.&&.  othr E.^. UserCompanyUser     E.==. userCompany E.^. UserCompanyUser
--          E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
--    )

company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey

-- for convenience in debugging
instance ToText (Maybe CompanyId) where
  toText Nothing    = toText ("-None-"::Text)
  toText (Just fsh) = toText $ unCompanyKey fsh

wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
  where
    wrapUL wgt = [whamlet|<ul .list--iconless>^{wgt}|]

-- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
--   NOTE: The widget must be wrapped with <ul>
wgtCompanies' :: Bool -> UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
wgtCompanies' useShort uid = do
    companies <- $(E.unValueN 4) <<$>> E.select do
      (usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
        `E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
      E.orderBy [E.asc (comp E.^. CompanyName)]
      return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
    let (mPri, topCmp, otherCmp) = procCmp mPri companies
        resWgt =
          [whamlet|
            $forall c <- topCmp
              <li>
                ^{c}
            $forall c <- otherCmp
              <li>
                ^{c}
          |]
    return $ toMaybe (notNull companies) (resWgt, companies)
  where
    procCmp _ [] = (0, [], [])
    procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
      let isTop  = cmpPrio >= maxPri
          cmpWgt = companyWidget' useShort isTop (cmpSh, cmpName, cmpSpr)
          (accPri,accTop,accRem) = procCmp maxPri cs
      in  ( max cmpPrio accPri
          , bool           accTop  (cmpWgt : accTop)    isTop -- lazy evaluation after repmin example, don't factor out the bool!
          , bool (cmpWgt : accRem)           accRem     isTop
          )

type AnySuperReason = Either SupervisorReason (Maybe Text)


addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault

-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
addDefaultSupervisors reason cid employees = do
  E.insertSelectWithConflictCount UniqueUserSupervisor
    (do
      (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
      E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
          E.&&.  spr E.^. UserCompanySupervisor
      E.distinct $ return $ UserSupervisor
        E.<#  (spr E.^. UserCompanyUser)
        E.<&>  usr
        E.<&> (spr E.^. UserCompanySupervisorReroute)
        E.<&> E.justVal cid
        E.<&> case reason of
                Nothing     -> E.justVal $ tshow SupervisorReasonCompanyDefault
                Just "NULL" -> E.nothing
                other       -> E.val other
    )
    (\old new ->
      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
      , UserSupervisorCompany E.=. E.justVal cid
      , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
      ]
    )


-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
-- TODO: check redundancies
addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
  E.insertSelectWithConflictCount UniqueUserSupervisor
    (do
      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
                            [ E.not__ $ usr E.^. UserCompanySupervisor ]
                        <>  maybeEmpty mbSuperId (\sprId -> [E.exists $ do
                              superv <- E.from $ E.table @UserSupervisor
                              E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
                                  E.&&.  superv E.^. UserSupervisorUser       E.==. usr E.^. UserCompanyUser
                            ])
                        <>  [          spr E.^. UserCompanySupervisor
                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
                            ]
      E.distinct $ return $ UserSupervisor
        E.<#  (spr E.^. UserCompanyUser)
        E.<&> (usr E.^. UserCompanyUser)
        E.<&> (spr E.^. UserCompanySupervisorReroute)
        E.<&> E.just (spr E.^. UserCompanyCompany)
        E.<&> E.val reason
    )
    (\old new ->
        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
        , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
        ] )

-- like `addDefaultSupervisors`, but selects all employees of given companies from database
-- TODO: check redundancies
addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
addDefaultSupervisorsAll reason mutualSupervision cids = do
  E.insertSelectWithConflictCount UniqueUserSupervisor
    (do
      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
                            [ E.not__ $ usr E.^. UserCompanySupervisor ]
                        <>  [          spr E.^. UserCompanySupervisor
                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
                            ]
      E.distinct $ return $ UserSupervisor
        E.<#  (spr E.^. UserCompanyUser)
        E.<&> (usr E.^. UserCompanyUser)
        E.<&> (spr E.^. UserCompanySupervisorReroute)
        E.<&> E.just (spr E.^. UserCompanyCompany)
        E.<&> E.val reason
    )
    (\old new ->
        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
        ] )

-- | removes user supervisorship on switch. WARNING: problems are only returned, but not yet written to DB via reportProblem
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
    usrRec      <- get404 uid
    newCompany  <- get404 newCompanyId
    mbUsrComp   <- getUserPrimaryCompany uid
    mbOldComp   <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
    mbUsrAvs    <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
    let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
        avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
        usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
                      (UserPostAddress =. Nothing)                                                   -- use company address indirectly instead
        usrPrefPost = userPrefersPostal usrRec
        usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
                      (UserPrefersPostal  =. companyPrefersPostal newCompany)
        usrPinPassUp = toMaybe (newCompany ^. _companyPinPassword . _not) (UserPinPassword =. Nothing)
        -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
        usrDisplayEmail :: UserEmail       = userDisplayEmail usrRec
        avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
        usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrPinPassUp, usrDisplayEmailUp]
        newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
        superReasonComDef = tshow SupervisorReasonCompanyDefault

    -- update uid usrUpdate
    -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
    case mbUsrComp of
      Nothing -> do -- create company user
        void $ insertUnique newUserComp
        newAPs <- addDefaultSupervisors' newCompanyId $ singleton uid
        $logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} to #{unCompanyKey newCompanyId}. #{newAPs} default company supervisors upserted.|]
        return (usrUpdate, mempty)
      Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
        | newCompanyId == oldCompanyId -> return mempty -- nothing to do
        | otherwise -> do -- switch company
            when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
            let newPrio = succ oldPrio
            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = newPrio}
              [UserCompanyPriority =. newPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
            -- supervised by uid
            supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
              usrSup <- E.from $ E.table @UserSupervisor
              E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
                  E.&&.  usrSup E.^. UserSupervisorCompany    E.~=. E.val oldCompanyId
                  E.&&.  usrSup E.^. UserSupervisorReason     E.~=. E.val superReasonComDef
              let singleSup = E.notExists $ do
                    othSup <- E.from $ E.table @UserSupervisor
                    E.where_ $ usrSup E.^. UserSupervisorUser     E.==. othSup E.^. UserSupervisorUser
                        E.&&.  othSup E.^. UserSupervisorCompany  E.~=. E.val oldCompanyId
                        E.&&.  othSup E.^. UserSupervisorReason   E.~=. E.val superReasonComDef
              return (usrSup, singleSup)
            newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
              E.delete $ do
                usrSup <- E.from $ E.table @UserSupervisor
                E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
              return $  [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
                        | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True)  <- supervisees ]
            -- supervisors of uid
            let superDeftFltr     = (UserSupervisorUser ==. uid) : (UserSupervisorReason  ~=. superReasonComDef)  -- default or no reason
                oldSubFltr        = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr                     -- old company or no company
            oldAPs <- if keepOldCompanySupervs
              then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
              else deleteWhereCount oldSubFltr
            nrDefSups <- addDefaultSupervisors' newCompanyId $ singleton uid -- CHECK HERE WITH LINES ABOVE
            newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
            let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
                problems = bcons oldSuper             (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
                         $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
                           newlyUnsupervised
                delupd = bool "deleted" "updated" keepOldCompanySupervs :: Text
            $logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} from #{unCompanyKey oldCompanyId} to #{unCompanyKey newCompanyId}. #{oldAPs} old APs #{delupd}. #{nrDefSups} default company supervisors upserted. #{newAPs} new company supervisors counted now.|]
            return (usrUpdate ,problems)

defaultSupervisorReasonFilter :: [Filter UserSupervisor]
defaultSupervisorReasonFilter =
        [UserSupervisorReason  ==. Nothing]
    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonCompanyDefault)]
    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonAvsSuperior   )]
--  ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?

-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
deleteDefaultSupervisorsForUsers cids sprs usrs =
    deleteWhereCount
      $ bcons (notNull cids) (UserSupervisorCompany     <-. (cids <&> Just))
      $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
      $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter

-- | retrieve maximum company user priority for a user

getCompanyUserMaxPrio :: UserId -> DB Int
getCompanyUserMaxPrio uid = do
  mbMaxPrio <- E.selectOne $ do
    usrCmp <- E.from $ E.table @UserCompany
    E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
    return . E.max_ $ usrCmp E.^. UserCompanyPriority
  return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio

-- | retrieve maximum company user priority for a user within SQL query
--   Note: if there a multiple top-companies, only one is returned
selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId))
selectCompanyUserPrime usr = E.subSelect $ selectCompanyUserPrimeHelper $ usr E.^. UserId

-- | like @selectCompanyUserPrime@, but directly usable, a simpler type to think about it `UserId -> DB (Maybe CompanyId)`
selectCompanyUserPrime' :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
                        => UserId -> ReaderT backend m (Maybe CompanyId)
selectCompanyUserPrime' uid = fmap E.unValue <<$>> E.selectOne $ selectCompanyUserPrimeHelper $ E.val uid

-- selectCompanyUserPrime'' :: UserId -> DB (Maybe CompanyId)
-- selectCompanyUserPrime'' uid = (userCompanyCompany . entityVal) <<$>> selectMaybe [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Asc UserCompanyCompany]

selectCompanyUserPrimeHelper :: E.SqlExpr (E.Value UserId) -> E.SqlQuery (E.SqlExpr (E.Value CompanyId))
selectCompanyUserPrimeHelper uid = do
  uc <- E.from $ E.table @UserCompany
  E.where_ $ uc E.^. UserCompanyUser E.==. uid
  E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
  return (uc E.^. UserCompanyCompany)