fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(log): add admin problem table

Browse Source
This commit is contained in:
Steffen Jost 2024-03-13 18:00:39 +01:00
parent 66eaa4f7dc
commit 08d2f8c2fc
9 changed files with 100 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
models/audit.model
View File

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

21
src/Audit.hs
View File

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

24
src/Audit/Types.hs
View File

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

37
src/Handler/Utils/Avs.hs
View File

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

14
src/Handler/Utils/Users.hs
View File

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

2
src/Model/Types/Misc.hs
View File

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

1
src/Utils.hs
View File

@ -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 ()

5
src/Utils/Lens.hs
View File

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

2
src/Utils/Users.hs
View File

@ -98,4 +98,4 @@ addNewUser AddUserData{..} = do
, userMatrikelnummer = audMatriculation
, userAuthentication = mkAuthMode audAuth
}
runDB $ insertUnique newUser
runDB $ insertUnique newUser