fix(avs): company superior emails become company wide supervisors

messages/uniworx/categories/admin/de-de-formal.msg

@@ -67,6 +67,7 @@ BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufze
 BearerTokenOverrideStart: Startzeitpunkt
 BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
 HeadingAdminTokens: Tokens ausstellen
+UserUnknown: Unbekannter Benutzer:in
 
 #templates adminFeautures
 StudyFeaturesDegrees: Abschlüsse
@@ -127,9 +128,11 @@ AdminProblemCreated: Erkannt
 AdminProblemInfo: Problembeschreibung
 AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
 AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
-AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
+AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
-AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
+AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
 AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma 
+AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
+AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer: 
 AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
 AdminProblemUser: Betroffener
 ProblemTableMarkSolved: Als erledigt markieren

messages/uniworx/categories/admin/en-eu.msg

@@ -67,6 +67,7 @@ BearerTokenExpiresTip: If no expiration time is given, the token will not expire
 BearerTokenOverrideStart: Start time
 BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
 HeadingAdminTokens: Issue tokens
+UserUnknown: User unknown
 
 #templates adminfeatures
 StudyFeaturesDegrees: Degrees
@@ -128,8 +129,10 @@ AdminProblemInfo: Problem
 AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
 AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
 AdminProblemNewCompany: New company from AVS; verify and add default supervisors
-AdminProblemSupervisorNewCompany b: This default company supervisor #{boolText mempty "with reroute" b} changed to new company 
+AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company 
 AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company 
+AdminProblemCompanySuperiorChange: New company wide superior.
+AdminProblemCompanySuperiorPrevious: Previous superior: 
 AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
 AdminProblemUser: Affected
 ProblemTableMarkSolved: Mark done

src/Audit/Types.hs

@@ -276,6 +276,11 @@ data AdminProblem
     , adminProblemCompany           :: CompanyId                -- old company
     , adminProblemSupervisorReroute :: Bool                     -- reroute included?
     }
+  | AdminProblemCompanySuperiorChange                           -- a company received a new superior user through AVS
+    { adminProblemUser              :: UserId                   -- new superior user
+    , adminProblemCompany           :: CompanyId                -- affected company
+    , adminProblemUserOld           :: Maybe UserId             -- previous superior
+    }
   | AdminProblemNewlyUnsupervised
     { adminProblemUser              :: UserId                   -- user who had a supervisor but no longer has, due to user company change
     , adminProblemCompanyOld        :: Maybe CompanyId          -- old company

src/Handler/Admin.hs

@@ -375,28 +375,5 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
       return (act, usrSet)
 
--- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
+-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
--- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
+-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils
--- adminProblemCell AdminProblemNewCompany{}                                 
---   = i18nCell MsgAdminProblemNewCompany
--- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} 
---   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
--- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
---   = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
--- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}  
---   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
--- adminProblemCell AdminProblemUnknown{adminProblemText}  
---   = textCell $ "Problem: " <> adminProblemText
-
-
--- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) 
--- msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
--- msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemSupervisorNewCompany, text2message ": ", company2msg  comp, text2message " -> ", company2msg newComp]
--- msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemSupervisorLeftCompany, text2message ": ", company2msg  comp]
--- msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
--- msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
---   someMessages ["Problem: ", err]

src/Handler/Utils.hs

@@ -164,7 +164,7 @@ redirectKeepGetParams route = liftHandler $ do
   redirect (route, getps)
 
 
-adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
+adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
 -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
 adminProblemCell AdminProblemNewCompany{}
   = i18nCell MsgAdminProblemNewCompany
@@ -172,6 +172,10 @@ adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminP
   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
   = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
+  = i18nCell MsgAdminProblemCompanySuperiorChange
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
+  = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
 adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemUnknown{adminProblemText}
@@ -187,6 +191,8 @@ msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, admin
   SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
 msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
   SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
+msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
+  SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
 msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
   SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
 msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
@@ -198,4 +204,3 @@ updateAutomatic True  = mempty
 updateAutomatic False = do
   msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
   messageTooltip msg
-  

src/Handler/Utils/Avs.hs

@@ -396,7 +396,6 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
             superReasonComDef = tshow SupervisorReasonCompanyDefault
             newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
 
-
         usr_up2 <- case oldAvsFirmInfo of
           _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
               -> return mempty                                                                --  => do nothing
@@ -444,7 +443,6 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                   -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
                   -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
                   -- return pst_up
-        repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId        -- ensure firmInfo superior is supervisor, must be executed after updating company default supervisors
         update usrId $ usr_up2 <> usr_up1                                         -- update user eventually
         update uaId    avs_ups                                                    -- update stored avsinfo for future updates
       return (apid, usrId)
@@ -556,62 +554,11 @@ createAvsUserById muid api = do
               void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
               -- Supervision
               addCompanySupervisors cid uid
-              repsertSuperiorSupervisor (Just cid) firmInfo uid
               -- Save AVS data for future updates
               insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
               return uid
 
 
--- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
-repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
-repsertSuperiorSupervisor cid afi uid = 
-  whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
-    (altM (guessUserByEmail $ stripCI supemail)
-          (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)            
-    ) $ \supid -> do
-      let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-          newSupervisor  = UserSupervisor supid uid False cid reasonSuperior
-      deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] -- delete previous superiors, if any
-      -- void $ upsertBy (UniqueUserSupervisor supid uid) newSupervisor [company =. cid, reason =. reasonSuperior]          -- always update supervisor reason
-      void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior                                               -- do not change existing supervisor relationship
-
--- TODO: CR3: user upsertCompanySuperior instead of repsertSuperiorSupervisor
--- upsert company supervisor from AvsFirmEMailSuperior
-upsertCompanySuperior :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
-upsertCompanySuperior newAfi mbOldAfi = runMaybeT $ do
-    supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
-    supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
-                           (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
-    cid <- MaybeT $ getAvsCompanyId newAfi    
-    lift $ do 
-      void $ runMaybeT $ do -- remove old superior, if any
-        oldAfi  <- MaybeT $ pure mbOldAfi
-        oldSeml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
-        oldSup  <- MaybeT $ guessUserByEmail $ stripCI oldSeml
-        oldCid  <- MaybeT $ getAvsCompanyId oldAfi
-        when (oldCid == cid && oldSup /= supid) $ lift $ do
-          let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-          deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company
-          -- switch supervison
-          -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
-          E.update $ \usuper -> do
-            E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
-            E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
-                E.&&.  usuper E.^. UserSupervisorCompany    E.==. E.justVal cid
-                E.&&.  usuper E.^. UserSupervisorReason     E.==. E.val reasonSuperior
-                E.&&. E.notExists (do
-                    newSuper <- E.from $ E.table @UserSupervisor
-                    E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
-                        E.&&.  newSuper E.^. UserSupervisorUser       E.==. newSuper E.^. UserSupervisorUser
-                  )
-          deleteWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any          
-      -- upsert new superior company supervisor
-      void $ upsertBy (UniqueUserCompany supid cid)
-                            (UserCompany supid cid True False 1 True)
-                            [UserCompanySupervisor =. True]
-      return (cid,supid)
-
-
 getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
 getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
 
@@ -637,7 +584,7 @@ upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
     mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
     $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
-    case (mbFirmEnt, mbOldAvsFirmInfo) of
+    cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
       (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
         afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
                 then return $ newAvsFirmInfo ^. _avsFirmFirmNo
@@ -680,6 +627,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
           _otherwise -> return res_cmp
         $logInfoS "AVS" "Update company completed."
         return res_cmp2
+    void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo                -- ensure firmInfo superior is supervisor
+    return cmpEnt
   where
     firmInfo2key =
         CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
@@ -692,6 +641,69 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       ]
 
+-- upsert company supervisor from AvsFirmEMailSuperior
+upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
+upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
+    supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
+    cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
+    supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
+                           (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
+    lift $ do
+      let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+      oldChanges <- runMaybeT $ do -- remove old superior, if any
+        oldAfi <- MaybeT $ pure mbOldAfi
+        oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
+        oldCid <- MaybeT $ getAvsCompanyId oldAfi
+        oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
+        let supChange = oldSup /= supid
+        when (supChange && oldCid == cid) $ lift $ do
+          -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
+          -- switch supervison
+          -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
+          E.update $ \usuper -> do
+            E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
+            E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
+                E.&&.  usuper E.^. UserSupervisorCompany    E.==. E.justVal cid
+                E.&&.  usuper E.^. UserSupervisorReason     E.==. E.val reasonSuperior
+                E.&&. E.notExists (do
+                    newSuper <- E.from $ E.table @UserSupervisor
+                    E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
+                        E.&&.  newSuper E.^. UserSupervisorUser       E.==. newSuper E.^. UserSupervisorUser
+                  )
+          deleteWhere [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any
+        return (supChange, oldSup)
+      let supChange = fst <$> oldChanges
+          oldSup    = snd <$> oldChanges
+      unless (supChange == Just False) $ do
+        -- upsert new superior company supervisor
+        suprEnt <- upsertBy (UniqueUserCompany supid cid)
+                              (UserCompany supid cid True False 1 True)
+                              [UserCompanySupervisor =. True]
+        E.insertSelectWithConflict UniqueUserSupervisor
+          (do
+            usr <- E.from $ E.table @UserCompany
+            E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+                -- E.&&. E.notExists (do                                                              -- restrict to primary company only
+                --     othr <- E.from $ E.table @UserCompany
+                --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+                --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+                --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+                --   )
+            return $ UserSupervisor
+              E.<#  E.val supid
+              E.<&> (usr E.^. UserCompanyUser)
+              E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
+              E.<&> E.justVal cid
+              E.<&> E.val reasonSuperior
+          )
+          (\old new ->
+            [ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany]
+            , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ]
+            ]
+          )
+        reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
+      return (cid,supid)
+
 
 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
 queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User)    (E.^. UserId)      (\usr    -> usr E.^. UserId             `E.in_` E.vals uids)

src/Handler/Utils/Company.hs

@@ -62,6 +62,13 @@ addCompanySupervisors cid uid =
         userCompany <- E.from $ E.table @UserCompany
         E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
             E.&&.  userCompany E.^. UserCompanySupervisor
+        --  E.&&. E.notExists (do                                                              -- restrict to primary company only
+        --      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
+        --    )
+
         return $ UserSupervisor
           E.<#  (userCompany E.^. UserCompanyUser)
           E.<&>  E.val uid

src/Handler/Utils/Widgets.hs

@@ -61,11 +61,18 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
 userWidget :: HasUser c => c -> Widget
 userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
 
+userIdWidget :: UserId -> Widget
+userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
+
 linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
 linkUserWidget lnk (Entity uid usr) = do
   uuid <- encrypt uid
   simpleLink (userWidget usr) (lnk uuid)
 
+-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
+linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
+linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
+
 userEmailWidget :: HasUser c => c -> Widget
 userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
 
@@ -285,4 +292,3 @@ jsonWidget x = jsonWidgetAux $ toJSON x
               <dt .deflist__dt>#{k}
               <dd .deflist__dd>^{jsonWidgetAux v}
         |]
-      

src/Utils.hs

@@ -963,6 +963,7 @@ maybeT x m = runMaybeT m >>= maybe x return
 maybeT_ :: Monad m => MaybeT m () -> m ()
 maybeT_ = void . runMaybeT
 
+-- Note: for MaybeT, hoistMaybe is more general than the equivalent MaybeT . pure, but also leads to much worse error messages
 hoistMaybe :: MonadPlus m => Maybe a -> m a
 -- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
 hoistMaybe = maybe mzero return

test/Database/Fill.hs

@@ -802,6 +802,8 @@ fillDb = do
   insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany ffacil   ) Nothing Nothing
   insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany fhamann fraportAg ffacil True ) Nothing Nothing
   insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany gkleen  ffacil fraGround False) Nothing Nothing
+  insert_ $ ProblemLog now (toJSON $ AdminProblemCompanySuperiorChange jost    fraportAg (Just gkleen)) Nothing Nothing
+  insert_ $ ProblemLog now (toJSON $ AdminProblemCompanySuperiorChange fhamann fraGround       Nothing) Nothing Nothing
   insert_ $ ProblemLog now (toJSON $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing
 
   let