diff --git a/models/audit.model b/models/audit.model index 3cd567a13..42364c829 100644 --- a/models/audit.model +++ b/models/audit.model @@ -8,7 +8,7 @@ TransactionLog instance InstanceId initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP - info Value -- JSON-encoded `Transaction` + info Value -- JSON-encoded `Transaction`. Value allows full backwards compatibility deriving Eq Read Show Generic InterfaceLog @@ -29,3 +29,10 @@ InterfaceHealth hours Int UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique deriving Eq Read Show Generic + +ProblemLog + time UTCTime default=now() + info Value -- generic JSON Value allows maximum backwards compatibility + solved UTCTime Maybe + solver UserId Maybe -- User who marked this problem as done + deriving Eq Read Show Generic \ No newline at end of file diff --git a/src/Audit.hs b/src/Audit.hs index f4deba9ba..06c5ca3d6 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -9,6 +9,7 @@ module Audit , AuditRemoteException(..) , getRemote , logInterface, logInterface' + , reportAdminProblem ) where @@ -169,3 +170,23 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS , transactionInterfaceInfo = interfaceLogInfo , transactionInterfaceSuccess = Just interfaceLogSuccess } + +reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , MonadHandler m + -- , HasCallStack + ) + => AdminProblem -- ^ Problem to record + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a problem that needs interventions by admins +-- +-- - `problemLogTime` is now +-- - `problemSolver` is Nothing, we do not record the person who caused it +reportAdminProblem problem@(toJSON -> problemLogInfo) = do + problemLogTime <- liftIO getCurrentTime + let problemLogSolved = Nothing + problemLogSolver = Nothing + insert_ ProblemLog{..} + $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack) + + diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 976171ec4..6f5831a37 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -4,6 +4,7 @@ module Audit.Types ( Transaction(..) + , AdminProblem(..) ) where import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) @@ -251,4 +252,25 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "transaction" "data" } ''Transaction -derivePersistFieldJSON ''Transaction \ No newline at end of file +derivePersistFieldJSON ''Transaction + + + +-- Datatype for raising admin awareness to certain problems +-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries + +data AdminProblem + = AdminProblemNewCompany -- new company without supervisors has been created + { adminProblemCompany :: CompanyId + } + | AdminProblemUnknown -- placeholder to avoid hlint newtype suggestion while we have few problems yet + deriving (Eq, Ord, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "problem" "data" + } ''AdminProblem + +derivePersistFieldJSON ''AdminProblem diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 3fc321733..aae3a9a5c 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -8,6 +8,7 @@ -- Module for functions directly related to the AVS interface, -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification +-- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting. module Handler.Utils.Avs ( guessAvsUser @@ -44,6 +45,7 @@ import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionExce import Handler.Utils.Company import Handler.Utils.Qualification import Handler.Utils.Memcached +import Handler.Utils.Users import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) @@ -503,9 +505,15 @@ updateAvsUserByIds apids = do , UserAvsLastPersonInfo =. Just newAvsPersonInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo ] - -- + -- + -- TODO: Update UserCompany too + -- TODO #124 Add an old default supervisor to an Admin TODO-List + -- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen + -- TODO #36 "company postal preference" + -- lift $ do -- no more maybeT neeed from here - update usrId usr_ups + update usrId usr_ups + -- update company association oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo) let oldCompanyId = entityKey <$> oldCompanyMb newCompanyId <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo @@ -515,18 +523,16 @@ updateAvsUserByIds apids = do case oldAvsFirmInfo of _ | oldCompanyId == Just newCompanyId -- company unchanged entirely -> return () - -- TODO: Update UserCompany too - -- TODO #124 Add an old default supervisor to an Admin TODO-List - -- Add function to use a secondary company post address that won't be updated - -- TODO #76 -- aktuelle Firmen löschen - -- TODO #36 - -- TODO add EmailSuperior to UserSupervisor if not alreadu, using failsafe LDAP lookup if possible (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged -> return () (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged -> return () _ -- company changed completely - -> do + -> do -- switch company + whenIsJust oldCompanyId (deleteBy . UniqueUserCompany usrId) + forMM_ (get newCompanyId) $ \Company{} -> + void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults + let superReasonComDef = tshow SupervisorReasonCompanyDefault superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef] @@ -552,6 +558,15 @@ updateAvsUserByIds apids = do -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins -- TODO continue here return () + -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors + whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ + (altM (guessUserByEmail $ supemail ^. from _CI) + (maybeCatchAll $ Just . entityKey <$> ldapLookupAndUpsert supemail) + ) $ \supid -> do + let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] + void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior + -- update stored avsinfo update uaId avs_ups return $ Set.singleton (apid, usrId) @@ -584,7 +599,9 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyEmail = newAvsFirmInfo ^. _avsFirmPrimaryEmail . _Just . from _CI . re _Just } - insert $ foldl' upd dmy firmInfo2company + newId <- insert $ foldl' upd dmy firmInfo2company + reportAdminProblem $ AdminProblemNewCompany newId + return newId (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index df3de339c..8c3276d92 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -12,7 +12,7 @@ module Handler.Utils.Users , NameMatchQuality(..) , matchesName , GuessUserInfo(..) - , guessUser + , guessUser, guessUserByEmail , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser , getUserEmail @@ -199,6 +199,18 @@ getSupervisees = do computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode +guessUserByEmail :: UserEmail -> DB (Maybe UserId) +guessUserByEmail eml = listToMaybe <$> selectKeysList + (ofoldl1Ex' (||.) + [ [UserDisplayEmail ==. eml] + , [UserEmail ==. eml] + , [UserIdent ==. eml] + -- , [UserLdapPrimaryKey ==. Text.stripSuffix "@fraport.de" $ CI.foldedCase eml] + ] + ) + [ Asc UserEmail -- Unique, to ensure reproducable results + , LimitTo 1 + ] data GuessUserInfo = GuessUserMatrikelnummer diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index e407cdd7d..10fa045b6 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -60,12 +60,14 @@ derivePersistField "Theme" data SupervisorReason = SupervisorReasonCompanyDefault + | SupervisorReasonAvsSuperior | SupervisorReasonUnknown deriving (Eq, Ord, Enum, Bounded, Generic) deriving anyclass (Universe, Finite, NFData) instance Show SupervisorReason where show SupervisorReasonCompanyDefault = "Firmenstandard" + show SupervisorReasonAvsSuperior = "Vorgesetzer" show SupervisorReasonUnknown = "Unbekannt" diff --git a/src/Utils.hs b/src/Utils.hs index a8393c4ba..09f4140ad 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -927,6 +927,7 @@ filterMaybe _ _ = Nothing -- | also referred to as whenJust and forM_ -- also see `foldMapM` if a Monoid value is to be returned +-- also see `forMM_` if the maybe is produced by a monadic action whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index a5ac92d7e..af3e2bb7b 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -13,6 +13,8 @@ import Model import Model.Rating import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..)) +import Audit.Types (AdminProblem(..)) + import Control.Lens as Utils.Lens hiding ( (<.>) , universe @@ -311,7 +313,8 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog --- makeLenses_ ''InterfaceLog -- not needed +makeLenses_ ''ProblemLog +makeLenses_ ''AdminProblem -------------------------- -- Fields for `UniWorX` -- diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index 2339fbed5..c5d08cef6 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -98,4 +98,4 @@ addNewUser AddUserData{..} = do , userMatrikelnummer = audMatriculation , userAuthentication = mkAuthMode audAuth } - runDB $ insertUnique newUser \ No newline at end of file + runDB $ insertUnique newUser \ No newline at end of file