chore(avs): WIP update UserCompany accodring to AVS

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

@@ -123,12 +123,15 @@ ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
 
 AdminProblemSolved: Erledigt
 AdminProblemSolver: Bearbeitet von
-AdminProblemCreated: Zeitpunkt
+AdminProblemCreated: Erkannt
 AdminProblemInfo: Problembeschreibung
 AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert
+AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet
 AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
+AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
+AdminProblemUser: Betroffener
 ProblemTableMarkSolved: Als erledigt markieren
-ProblemTableUnknownTodo: Unbekanntes ToDo Problem
+ProblemTableMarkUnsolved: Erledigt Markierung löschen
 
 InterfacesOk: Schnittstellen sind ok.
 InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!

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

@@ -123,12 +123,15 @@ ProblemsInterfaceSince: Only considering successes and errors since
 
 AdminProblemSolved: Done
 AdminProblemSolver: Solved by
-AdminProblemCreated: Creation time
+AdminProblemCreated: Recognized
 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: Default company supervisor #{boolText mempty "with reroute" b} changed to new company 
+AdminProblemUser: Affected
 ProblemTableMarkSolved: Mark done
-ProblemTableUnknownTodo: Unknown todo problem
+ProblemTableMarkUnsolved: Reopen as undone
 
 InterfacesOk: Interfaces are ok.
 InterfacesFail n: #{pluralENsN n "interface problem"}!

src/Audit/Types.hs

@@ -262,19 +262,29 @@ derivePersistFieldJSON ''Transaction
 -- 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 
+  = AdminProblemNewCompany                                      -- new company was noticed, presumably without supervisors
-    { adminProblemCompany :: CompanyId
+    { adminProblemCompany           :: CompanyId
     }
-  | AdminProblemUnknown -- placeholder to avoid hlint newtype suggestion while we have few problems yet
+  | AdminProblemSupervisorNewCompany                            
-    { adminProblemText :: Text
+    { adminProblemUser              :: UserId                         -- a default supervisor has changed company
+    , adminProblemCompany           :: CompanyId                      -- old company where the user had default supervisor rights
+    , adminProblemCompanyNew        :: CompanyId                      -- new company of the user
+    , adminProblemSupervisorReroute :: Bool                           -- reroute included?
+    }
+  | AdminProblemUnknown                                         -- miscellanous problem, just displaying text
+    { adminProblemText              :: Text    
     }
   deriving (Eq, Ord, Read, Show, Generic)
 
+-- Columns shown in problem table: adminProblemCompany, adminProblemUser
+-- For display: add clause to Handler.Admin.adminProblemCell
+
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 2
   , fieldLabelModifier = camelToPathPiece' 2
   , tagSingleConstructors = True
   , sumEncoding = TaggedObject "problem" "data"
+  , rejectUnknownFields = False
   } ''AdminProblem
 
 derivePersistFieldJSON ''AdminProblem

src/Database/Esqueleto/Utils.hs

@@ -41,13 +41,13 @@ module Database.Esqueleto.Utils
   , greatest, least
   , abs
   , SqlProject(..)
-  , (->.), (->>.), (#>>.)
+  , (->.), (->>.), (->>>.), (#>>.)
   , fromSqlKey
   , unKey
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , num2text
+  , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
@@ -645,6 +645,12 @@ infixl 8 ->>.
 (->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) 
 (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
 
+infixl 8 ->>>.
+
+-- Unsafe variant to obtain a DB key from a JSON field. Use with caution!
+(->>>.) :: (PersistField (Key entity)) => E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe (Key entity)))
+(->>>.) expr t = E.unsafeSqlCastAs "int" $ E.unsafeSqlBinOp "->>" expr $ E.val t
+
 infixl 8 #>>.
 
 (#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
@@ -692,6 +698,10 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
 num2text = E.unsafeSqlCastAs "text"
 
+-- unsafe, use with care!
+-- text2num :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value n)
+-- text2num = E.unsafeSqlCastAs "int"
+
 day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
 

src/Foundation/I18n.hs

@@ -210,6 +210,9 @@ maybeBoolMessage Nothing      n _ _ = n
 maybeBoolMessage (Just True)  _ t _ = t
 maybeBoolMessage (Just False) _ _ f = f
 
+-- | Convenience function avoiding type signatures
+boolText :: Text -> Text -> Bool -> Text
+boolText = bool
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving stock (Eq, Ord, Read, Show)

src/Handler/Admin.hs

@@ -43,7 +43,7 @@ single = uncurry Map.singleton
 
 -- Types and Template Haskell
 data ProblemTableAction = ProblemTableMarkSolved
-                        | ProblemTableUnknownTodo -- Placeholder, remove later, inculding associated Message
+                        | ProblemTableMarkUnsolved
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -51,7 +51,7 @@ nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''ProblemTableAction id
 
 data ProblemTableActionData = ProblemTableMarkSolvedData
-                            | ProblemTableUnknownTodoData -- Placeholder, remove later
+                            | ProblemTableMarkUnsolvedData -- Placeholder, remove later
   deriving (Eq, Ord, Read, Show, Generic)
 
 
@@ -119,21 +119,25 @@ handleAdminProblems mbProblemTable = do
     $(widgetFile "admin-problems")
 
 postAdminProblemsR = do 
-  (problemLogRes, problemLogTable) <- runDB mkProblemLogTable
+    (problemLogRes, problemLogTable) <- runDB mkProblemLogTable    
-  let procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
+    formResult problemLogRes procProblems
-      procProblems (ProblemTableMarkSolvedData, pids) = do
+    handleAdminProblems $ Just problemLogTable
-        mauid <- maybeAuthId
+  where
-        now <- liftIO getCurrentTime
+    procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
-        (fromIntegral -> oks) <- runDB $ updateWhereCount [ProblemLogSolved ==. Nothing, ProblemLogId <-. toList pids] 
+    procProblems (ProblemTableMarkSolvedData  , pids) = actUpdate True  pids 
-                                                          [ProblemLogSolved =. Just now, ProblemLogSolver =. mauid]
+    procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
-        let no_req = Set.size pids
-            mkind = if oks < no_req || no_req < 0 then Warning else Success
-        addMessageI mkind $ MsgAdminProblemsSolved oks
-        when (oks > 0) $ redirect AdminProblemsR -- reload to update all tables
-      procProblems (ProblemTableUnknownTodoData, _) = return () -- just a no-op
-  formResult problemLogRes procProblems
-  handleAdminProblems $ Just problemLogTable
 
+    actUpdate markdone pids = do
+      mauid <- maybeAuthId
+      now <- liftIO getCurrentTime
+      let (pls_fltr,newv,msg) | markdone  = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved)
+                              | otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened)
+      (fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids]
+                                                        [ProblemLogSolved =. newv, ProblemLogSolver =. mauid]
+      let no_req = Set.size pids
+          mkind = if oks < no_req || no_req <= 0 then Warning else Success
+      addMessageI mkind $ msg oks
+      when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
 
 getProblemUnreachableR :: Handler Html
 getProblemUnreachableR = do
@@ -284,27 +288,35 @@ retrieveDriversRWithoutF now = do
 
 
 
-type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
 queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog)
-queryProblem = $(E.sqlLOJproj 2 1)
+queryProblem = $(E.sqlLOJproj 3 1)
 
 querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
-querySolver = $(E.sqlLOJproj 2 2)
+querySolver = $(E.sqlLOJproj 3 2)
 
-type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User))
+queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryUser = $(E.sqlLOJproj 3 3)
+
+type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User))
 resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog)
 resultProblem = _dbrOutput . _1
 
 resultSolver :: Traversal' ProblemLogTableData (Entity User)
 resultSolver = _dbrOutput . _2 . _Just
 
+resultUser :: Traversal' ProblemLogTableData (Entity User)
+resultUser = _dbrOutput . _3 . _Just
+
 mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
 mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
   where
     dbtIdent = "problem-log" :: Text
-    dbtSQLQuery = \(problem `E.LeftOuterJoin` solver) -> do
+    dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
-                    EL.on (problem E.^. ProblemLogSolver E.==. solver E.?. UserId)
+                    -- EL.on (usr    E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo   E.->>. "user")) -- works
-                    return (problem, solver)
+                    EL.on (usr    E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user")
+                    EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
+                    return (problem, solver, usr)
     dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
     dbtProj = dbtProjId
     dbtColonnade = formColonnade $ mconcat
@@ -312,7 +324,8 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       , sortable (Just "time")    (i18nCell MsgAdminProblemCreated) $ \(   view $ resultProblem . _entityVal . _problemLogTime   -> t) ->           dateTimeCell t
       , sortable (Just "info")    (i18nCell MsgAdminProblemInfo)    $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
       , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
-      , sortable (Just "solved")  (i18nCell MsgAdminProblemSolver)  $ \(   view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
+      , sortable (Just "user")    (i18nCell MsgAdminProblemUser)    $ \(preview resultUser   -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable (Just "solved")  (i18nCell MsgAdminProblemSolved)  $ \(   view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
       , sortable (Just "solver")  (i18nCell MsgAdminProblemSolver)  $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       ]
     dbtSorting = mconcat
@@ -320,6 +333,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       , single ("info"  , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
       -- , single ("firm"  , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
       , single ("firm"  , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
+      , single ("user"  , sortUserNameBareM queryUser)
       , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
       , single ("solver", sortUserNameBareM querySolver)
       ]
@@ -331,7 +345,8 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       ]
     acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
     acts = mconcat
-      [ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData
+      [ singletonMap ProblemTableMarkSolved   $ pure ProblemTableMarkSolvedData
+      , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData
       ]
     dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -360,5 +375,9 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       return (act, usrSet)
 
 adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
-adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany
+adminProblemCell AdminProblemNewCompany{}                                 
-adminProblemCell AdminProblemUnknown{adminProblemText} = textCell $ "Problem: " <> adminProblemText
+  = i18nCell MsgAdminProblemNewCompany
+adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} 
+  = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
+adminProblemCell AdminProblemUnknown{adminProblemText}  
+  = textCell $ "Problem: " <> adminProblemText

src/Handler/Utils/Avs.hs

@@ -513,25 +513,38 @@ updateAvsUserByIds apids = do
       --
       lift $ do -- no more maybeT neeed from here 
         update usrId usr_ups
-        -- update company association
+        -- update company association & supervision
         oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo)
         let oldCompanyId = entityKey <$> oldCompanyMb        
         newCompanyId <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
-        -- newCompanyMb <- get newCompanyId
+        newCompanyMb <- get newCompanyId
-        -- adjusting supervisors
+        
+        -- TODO: possibly change postal preferences
+        let _prefPostal = maybe True companyPrefersPostal newCompanyMb
+        -- _primaryCompanyIdMb <- getUserPrimaryCompany usrId (pure . companyShorthand)
+        -- possibly add to usr_ups!
+
         -- case (oldAvsFirmInfo, oldCompanyMb, newCompanyMb) of 
         case oldAvsFirmInfo of 
           _ | oldCompanyId == Just newCompanyId                                               -- company unchanged entirely
               -> return ()
-          (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo        -- company address unchanged
+          -- (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo        -- company address unchanged
-              -> return ()
+          --     -> return ()
-          (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo        -- company primary email unchanged
+          -- (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo        -- company primary email unchanged
-              -> return ()
+          --     -> return ()
           _                                                                                   -- company changed completely 
               -> do -- switch company
-                  whenIsJust oldCompanyId (deleteBy . UniqueUserCompany usrId)
+                  (join <$> ((getBy . UniqueUserCompany usrId) `traverse` oldCompanyId)) >>= (\case
-                  forMM_ (get newCompanyId) $ \Company{} ->
+                      Nothing -> do 
-                    void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults
+                        void $ insertUnique $ UserCompany usrId newCompanyId False False 1 True
+                      (Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}}) -> do
+                        when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
+                        delete ucidOld
+                        void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True
+                    )
+
+                  -- 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 ~=.)

src/Handler/Utils/Users.hs

@@ -15,6 +15,7 @@ module Handler.Utils.Users
   , guessUser, guessUserByEmail
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
+  , getUserPrimaryCompany
   , getUserEmail
   , getEmailAddress, getJustEmailAddress
   , getEmailAddressFor, getJustEmailAddressFor
@@ -75,8 +76,8 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
     assemble = Text.intercalate "."
 
 
-getUserCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
+getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
-getUserCompanyAddress uid prj = runMaybeT $ do
+getUserPrimaryCompany uid prj = runMaybeT $ do
   Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ 
     selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] 
                 [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
@@ -125,7 +126,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
     = return $ Just userDisplayEmail
   | otherwise
     = do
-        compEmailMb <- getUserCompanyAddress uid companyEmail
+        compEmailMb <- getUserPrimaryCompany uid companyEmail
         return $ pickValidEmail' $ mcons compEmailMb [userEmail]
 
 -- address is prefixed with userDisplayName
@@ -135,7 +136,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
     = prefixMarkupName pa
   | otherwise
     = do
-        getUserCompanyAddress uid companyPostAddress >>= \case
+        getUserPrimaryCompany uid companyPostAddress >>= \case
           (Just pa)
               -> prefixMarkupName pa
           Nothing 
@@ -153,7 +154,7 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
     = return res
   | otherwise
     = do
-        getUserCompanyAddress uid companyPostAddress >>= \case
+        getUserPrimaryCompany uid companyPostAddress >>= \case
           res@(Just _)
               -> return res
           Nothing 

src/Utils/DB.hs

@@ -4,13 +4,12 @@
 
 module Utils.DB where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (addMessageI)
 
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Database.Esqueleto.Legacy as E
--- import Database.Persist -- currently not needed here
 
 import Utils
 import Control.Lens
@@ -20,7 +19,7 @@ import Control.Monad.Catch hiding (bracket)
 
 import qualified Utils.Pool as Custom
 
-import Database.Persist.Sql (runSqlConn)
+import Database.Persist.Sql (runSqlConn) -- , updateWhereCount)
 
 import GHC.Stack (HasCallStack, CallStack, callStack)
 
@@ -219,6 +218,25 @@ class WithRunDB backend m' m | m -> backend m' where
 instance WithRunDB backend m (ReaderT backend m) where
   useRunDB = id
 
+-- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special:
+-- updateWithMessage 
+--   :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend
+--       , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)]))
+--   => url                 -- where to redirect, if changes were mage
+--   -> [Filter val]        -- update filter
+--   -> [Update val]        -- actual update
+--   -> a                   -- expected updates 
+--   -> (a -> msg)          -- message to add with number of actual changes
+--   -> HandlerFor site ()
+-- updateWithMessage route flt upd no_req msg = do
+--   (fromIntegral -> oks) <- runDB $ updateWhereCount flt upd
+--   let mkind = if oks < no_req || no_req <= 0 then Warning else Success
+--   addMessageI mkind $ msg oks
+--   when (oks > 0) $ do -- reload to ensure updates are displayed
+--     getps <- reqGetParams <$> getRequest
+--     redirect (route, getps)
+
+
 -- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b }
 
 -- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))

test/Database/Fill.hs

@@ -787,6 +787,8 @@ fillDb = do
 
   insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany fraportAg) Nothing Nothing
   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 $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing
 
   let