chore(log): add admin problem table

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

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

src/Audit/Types.hs

@@ -4,6 +4,7 @@
 
 module Audit.Types
   ( Transaction(..)
+  , AdminProblem(..)
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -252,3 +253,24 @@ deriveJSON defaultOptions
   } ''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

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 ((:&)(..))
@@ -504,8 +506,14 @@ updateAvsUserByIds apids = do
                     , 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 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

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

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"
 
 

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

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