diff --git a/models/users.model b/models/users.model index 40ae1bee2..77a330744 100644 --- a/models/users.model +++ b/models/users.model @@ -88,7 +88,8 @@ UserGroupMember UserCompany user UserId company CompanyId OnDeleteCascade OnUpdateCascade - supervisor Bool -- is this user a company supervisor? + supervisor Bool -- should this user be made supervisor for all _new_ users associated with this company? + supervisorReroute Bool default=true -- if supervisor is true, should this supervisor receive email for _new_ company users? UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once deriving Generic UserSupervisor diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index c43da2b16..d231fd94d 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -182,7 +182,8 @@ upsertCampusUser upsertMode ldapData = do userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData - + --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? + oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] user@(Entity userId userRec) <- case oldUsers of diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 837bb5181..74990a803 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -12,15 +12,22 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Char as Char import qualified Data.Text as Text +import Database.Persist.Postgresql -- | Ensure that the given user is linked to the given company upsertUserCompany :: UserId -> Maybe Text -> DB () upsertUserCompany uid (Just cName) | notNull cName = do cid <- upsertCompany cName void $ upsertBy (UniqueUserCompany uid cid) - (UserCompany uid cid False) - [] -upsertUserCompany uid _ = deleteWhere [ UserCompanyUser ==. uid ] + (UserCompany uid cid False False) + [] + superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] + upsertManyWhere [ UserSupervisor super uid reroute + | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs + ] [] [] [] +upsertUserCompany uid _ = + deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors? + upsertCompany :: Text -> DB CompanyId upsertCompany cName = diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index d40992ab3..eacfb92a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -821,7 +821,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ UserSupervisor E.<# E.val newUserId E.<&> (userSupervisor E.^. UserSupervisorUser) - E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) ) (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) deleteWhere [ UserSupervisorSupervisor ==. oldUserId] @@ -847,6 +847,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<# E.val newUserId E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanySupervisor) + E.<&> (userCompany E.^. UserCompanySupervisorReroute) ) (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) deleteWhere [ UserCompanyUser ==. oldUserId] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index e4545302e..e5a687782 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -28,6 +28,8 @@ import Data.List (foldl) import System.Directory (getModificationTime) import System.FilePath.Glob (glob) +import Database.Persist.Postgresql + {- Needed for File Tests only import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) @@ -435,7 +437,7 @@ fillDb = do manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] insertMany_ [UserAvs (AvsPersonId n) uid n | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] - + let tmin = -1 tmax = 2 trange = [tmin..tmax] @@ -488,20 +490,33 @@ fillDb = do nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False Nothing ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing - void . insert' $ UserCompany jost fraportAg True - void . insert' $ UserCompany svaupel nice True - void . insert' $ UserCompany gkleen nice False - void . insert' $ UserCompany gkleen fraGround False - void . insert' $ UserCompany fhamann bpol False - void . insert' $ UserCompany fhamann ffacil True - void . insert' $ UserCompany fhamann nice False - void . insert' $ UserSupervisor jost gkleen True - void . insert' $ UserSupervisor jost svaupel False - void . insert' $ UserSupervisor jost sbarth False - void . insert' $ UserSupervisor jost tinaTester True - void . insert' $ UserSupervisor svaupel gkleen False - void . insert' $ UserSupervisor svaupel fhamann True - void . insert' $ UserSupervisor sbarth tinaTester True + void . insert' $ UserCompany jost fraportAg True True + void . insert' $ UserCompany svaupel nice True False + void . insert' $ UserCompany gkleen nice False False + void . insert' $ UserCompany gkleen fraGround False True + void . insert' $ UserCompany fhamann bpol False False + void . insert' $ UserCompany fhamann ffacil True True + void . insert' $ UserCompany fhamann nice False False + -- void . insert' $ UserSupervisor jost gkleen True + -- void . insert' $ UserSupervisor jost svaupel False + -- void . insert' $ UserSupervisor jost sbarth False + -- void . insert' $ UserSupervisor jost tinaTester True + -- void . insert' $ UserSupervisor svaupel gkleen False + -- void . insert' $ UserSupervisor svaupel fhamann True + -- void . insert' $ UserSupervisor sbarth tinaTester True + let supvs = [ UserSupervisor jost gkleen True + , UserSupervisor jost svaupel False + , UserSupervisor jost sbarth False + , UserSupervisor jost tinaTester True + , UserSupervisor svaupel gkleen False + , UserSupervisor svaupel fhamann True + , UserSupervisor sbarth tinaTester True + , UserSupervisor gkleen fhamann False + ] + upsertManyWhere supvs [] [] [] + -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok + -- insertMany_ supvs -- NOTE: multiple calls like this throw an error! + ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True avn <- insert' $ School "Fahrerausbildung" "FA" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True