-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

-- 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

wgtCompanies :: UserId -> DB (Maybe Widget)
wgtCompanies = \uid -> do
    companies <- 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
              <p>
                ^{c}
            $forall c <- otherCmp
              <p>
                ^{c}
          |]
    return $ toMaybe (notNull topCmp) resWgt
  where
    procCmp _ [] = (0, [], [])
    procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
      let isTop  = cmpPrio >= maxPri
          cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
          (accPri,accTop,accRem) = procCmp maxPri cs
      in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!

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 not yet written to DB via reportProblem yet
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)
        usrEmail :: UserEmail       = userDisplayEmail usrRec
        avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
        usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
                --  [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
    -- 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
        void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
        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
            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
              [UserCompanyPriority =. succ oldPrio, 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)
                oldSubFltr        = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
            oldAPs <- if keepOldCompanySupervs
              then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
              else deleteWhereCount oldSubFltr
            void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
            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
            return (usrUpdate ,problems)
  where
    newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
    superReasonComDef = tshow SupervisorReasonCompanyDefault

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

-- | 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

-- | deletes user company association and all company related supervision
-- WARNING: does not check for admin problems!
deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
deleteCompanyUser cid uids = (,,)
    <$> deleteWhereCount  [UserCompanyCompany    ==.      cid,  UserCompanyUser          <-. uids]
    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser       <-. uids) : defaultSupervisorReasonFilter)