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

chore(firm): improve efficiency of foreign supervisor filter

Browse Source
This commit is contained in:
Steffen Jost 2023-12-13 16:25:11 +01:00
parent ce45d26a21
commit f36f234c42
3 changed files with 100 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
src/Handler/Firm.hs
View File

@ -7,7 +7,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Handler.Firm module Handler.Firm
( getFirmAllR , postFirmAllR ( getFirmAllR , postFirmAllR
, getFirmUsersR , postFirmUsersR , getFirmUsersR , postFirmUsersR
, getFirmSupersR, postFirmSupersR , getFirmSupersR, postFirmSupersR
, getFirmCommR , postFirmCommR , getFirmCommR , postFirmCommR
@ -127,7 +127,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
faHandler (FirmActResetSupervisionData{..}, fids) = do faHandler (FirmActResetSupervisionData{..}, fids) = do
madId <- bool maybeAuthId (return Nothing) isAdmin madId <- bool maybeAuthId (return Nothing) isAdmin
let suprFltr = if let suprFltr = if
| isAdmin -> const E.true | isAdmin -> const E.true
| (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId | (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId
| otherwise -> const E.false | otherwise -> const E.false
@ -214,7 +214,7 @@ runFirmActionFormPost cid route isAdmin acts = do
return [whamlet| return [whamlet|
<section> <section>
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed> <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgFirmAction} _{MsgFirmAction}
<div> <div>
<p> <p>
_{MsgFirmActionInfo} _{MsgFirmActionInfo}
@ -248,14 +248,14 @@ addDefaultSupervisors cid employees = do
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
E.&&. spr E.^. UserCompanySupervisor E.&&. spr E.^. UserCompanySupervisor
return $ UserSupervisor E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser) E.<# (spr E.^. UserCompanyUser)
E.<&> usr E.<&> usr
E.<&> (spr E.^. UserCompanySupervisorReroute) E.<&> (spr E.^. UserCompanySupervisorReroute)
) )
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual -- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
E.insertSelectWithConflictCount UniqueUserSupervisor E.insertSelectWithConflictCount UniqueUserSupervisor
@ -263,16 +263,16 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
E.where_ $ E.and $ guardMonoid (not mutualSupervision) E.where_ $ E.and $ guardMonoid (not mutualSupervision)
[ E.not_ $ usr E.^. UserCompanySupervisor ] [ E.not_ $ usr E.^. UserCompanySupervisor ]
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
superv <- E.from $ E.table @UserSupervisor superv <- E.from $ E.table @UserSupervisor
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
]) ])
<> [ spr E.^. UserCompanySupervisor <> [ spr E.^. UserCompanySupervisor
, spr E.^. UserCompanyCompany `E.in_` E.vals cids , spr E.^. UserCompanyCompany `E.in_` E.vals cids
, usr E.^. UserCompanyCompany `E.in_` E.vals cids , usr E.^. UserCompanyCompany `E.in_` E.vals cids
] ]
return $ UserSupervisor E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser) E.<# (spr E.^. UserCompanyUser)
E.<&> (usr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute) E.<&> (spr E.^. UserCompanySupervisorReroute)
@ -291,7 +291,7 @@ addDefaultSupervisorsAll mutualSupervision cids = do
, spr E.^. UserCompanyCompany `E.in_` E.vals cids , spr E.^. UserCompanyCompany `E.in_` E.vals cids
, usr E.^. UserCompanyCompany `E.in_` E.vals cids , usr E.^. UserCompanyCompany `E.in_` E.vals cids
] ]
return $ UserSupervisor E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser) E.<# (spr E.^. UserCompanyUser)
E.<&> (usr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute) E.<&> (spr E.^. UserCompanySupervisorReroute)
@ -541,15 +541,15 @@ mkFirmAllTable isAdmin uid = do
usr <- E.from $ E.table @User usr <- E.from $ E.table @User
E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
) E.&&. (E.exists (do ) E.&&. (E.exists (do
usrCmp <- E.from $ E.table @UserCompany usrCmp <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
E.&&. usrCmp E.^. UserCompanySupervisor E.&&. usrCmp E.^. UserCompanySupervisor
E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
) E.||. E.exists (do ) E.||. E.exists (do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
E.&&. E.exists (do E.&&. E.exists (do
usrSub <- E.from $ E.table @UserCompany usrSub <- E.from $ E.table @UserCompany
E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
@ -559,20 +559,37 @@ mkFirmAllTable isAdmin uid = do
) )
) )
, single ("is-supervisor2" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do , single ("is-supervisor2" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User usr <- E.from $ E.table @User
`E.leftJoin` E.table @UserCompany
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) ) E.&&. E.exists (do
E.||. E.exists (do usrCmp <- E.from $ E.table @UserCompany
(usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser) E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId E.&&. (( usrCmp E.^. UserCompanySupervisor
E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId
) ) E.||. E.exists (do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
))
) )
) )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
-- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
-- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
-- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
-- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
-- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId)
-- E.||. E.exists (do
-- (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser)
-- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
-- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-- )
-- )
-- )
, single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User (usr :& usrCmp) <- E.from $ E.table @User
`E.innerJoin` E.table @UserCompany `E.innerJoin` E.table @UserCompany
@ -618,9 +635,9 @@ mkFirmAllTable isAdmin uid = do
[ fltrCompanyNameUI mPrev [ fltrCompanyNameUI mPrev
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
, prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser)
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "is-supervisor2") mPrev $ aopt textField (fslI MsgTableSupervisor) -- TODO: remove either one variant which works worse
, prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault)
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "is-supervisor2") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
] ]
@ -681,7 +698,7 @@ data FirmUserAction = FirmUserActNotify
nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmUserAction id embedRenderMessage ''UniWorX ''FirmUserAction id
data FirmUserActionData = FirmUserActNotifyData data FirmUserActionData = FirmUserActNotifyData
| FirmUserActResetSupervisionData | FirmUserActResetSupervisionData
{ firmUserActResetKeepOldSupers :: Maybe Bool { firmUserActResetKeepOldSupers :: Maybe Bool
-- , firmUserActResetMutualSupervision :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool
@ -746,7 +763,7 @@ mkFirmUserTable isAdmin cid = do
] ]
rawSupers <- E.select $ do rawSupers <- E.select $ do
(usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
@ -755,7 +772,7 @@ mkFirmUserTable isAdmin cid = do
-- supervisorField :: Field Handler UserId -- supervisorField :: Field Handler UserId
-- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
fsh = unCompanyKey cid fsh = unCompanyKey cid
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
@ -902,7 +919,7 @@ mkFirmUserTable isAdmin cid = do
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
getFirmUsersR = postFirmUsersR getFirmUsersR = postFirmUsersR
postFirmUsersR fsh = do postFirmUsersR fsh = do
isAdmin <- checkAdmin isAdmin <- checkAdmin
let cid = CompanyKey fsh let cid = CompanyKey fsh
(( Entity{entityVal=Company{..}} (( Entity{entityVal=Company{..}}
, E.Value nrCompanyUsers , E.Value nrCompanyUsers
@ -961,12 +978,12 @@ postFirmUsersR fsh = do
<li>#{usr} <li>#{usr}
|] |]
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
delSupers <- runDB delSupers <- runDB
$ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep
<* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers]
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
@ -1003,7 +1020,7 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmSuperAction id embedRenderMessage ''UniWorX ''FirmSuperAction id
data FirmSuperActionData = FirmSuperActNotifyData data FirmSuperActionData = FirmSuperActNotifyData
| FirmSuperActSwitchSuperData | FirmSuperActSwitchSuperData
{ firmSuperActSwitchSuper :: Maybe Bool { firmSuperActSwitchSuper :: Maybe Bool
, firmSuperActSwitchReroute :: Maybe Bool , firmSuperActSwitchReroute :: Maybe Bool
} }
@ -1169,7 +1186,7 @@ postFirmSupersR fsh = do
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
(nrRmSuper,nrRmActual) <- runDB $ (,) (nrRmSuper,nrRmActual) <- runDB $ (,)
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
<*> if firmSuperActRMSuperActive /= Just True <*> if firmSuperActRMSuperActive /= Just True
then return 0 then return 0
else E.deleteCount $ do else E.deleteCount $ do
spr <- E.from $ E.table @UserSupervisor spr <- E.from $ E.table @UserSupervisor
@ -1182,7 +1199,7 @@ postFirmSupersR fsh = do
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
(Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ]) (Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ])
(Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer] (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer]
, [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ]) , [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ])

2
src/Handler/Utils/StudyFeatures.hs
View File

@ -137,7 +137,7 @@ cacheStudyFeatureRelevance fFilter = do
E.on E.true E.on E.true
E.where_ $ fFilter studyFeatures E.where_ $ fFilter studyFeatures
E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures
return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) E.distinct $ return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
) )
( \_current _excluded -> [] ) ( \_current _excluded -> [] )

62
test/Database/Fill.hs
View File

@ -11,8 +11,9 @@ import "uniworx" Import hiding (Option(..), currentYear)
import qualified Data.Text.Encoding as TEnc import qualified Data.Text.Encoding as TEnc
import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Yesod.Auth.Util.PasswordStore as PWStore
import qualified Data.Set as Set import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Set as Set
import qualified Data.Map as Map
import Utils.Holidays import Utils.Holidays
@ -494,6 +495,15 @@ fillDb = do
, "Mark", "Paul", "Steven", "Andrew" , "Mark", "Paul", "Steven", "Andrew"
, "Kenneth", "Joshua", "George", "Kevin" , "Kenneth", "Joshua", "George", "Kevin"
, "Brian", "Edward", "Susan", "Ronald" , "Brian", "Edward", "Susan", "Ronald"
, "Nico", "Pascal", "Danielle", "Brendon"
, "Winston", "Luke", "Jeff", "Ben"
, "Asis", "Janika", "Claudio", "Frank"
, "Anna", "Ivo", "Merlin", "Fabienne"
, "Angela", "Alissa", "Fredrik", "Sharlee"
, "René", "Tuval", "Dom", "Fabian"
, "Steve", "Bruce", "Adrian", "Nicko"
, "Joakim", "Ylva", "Mats", "Emil"
, "Angus", "Seeb", "Thalia", "Manu"
] ]
surnames = [ "Smith", "Johnson", "Williams", "Brown" surnames = [ "Smith", "Johnson", "Williams", "Brown"
, "Jones", "Miller", "Davis", "Garcia" , "Jones", "Miller", "Davis", "Garcia"
@ -503,15 +513,17 @@ fillDb = do
, "Lopez", "Lee", "Gonzalez", "Harris" , "Lopez", "Lee", "Gonzalez", "Harris"
, "Clark", "Lewis", "Robinson", "Walker" , "Clark", "Lewis", "Robinson", "Walker"
, "Perez", "Hall", "Young", "Allen" , "Perez", "Hall", "Young", "Allen"
, "Loomis", "Amott", "Gluz", "Erlandsson"
, "Glanzmann", "Murphy", "Henzi", "Sutter"
, "Nasseri", "Wolf", "Quarta", "Fuhrmann"
, "McCall", "Kilpatrick", "Ling", "Gordon"
, "Sallach", "Ratajczak", "Friedrich", "Schillo"
, "Völkl", "Dahn", "Berthiaume", "Crey"
, "Murray", "Dickinson", "McBrain", "Gers"
, "Nilsson", "Eriksson", "Fehrm", "Grahn"
, "Winkler", "Levermann", "Bellazecca", "Lotter"
] ]
middlenames = [ Nothing, Just "Jamesson" ] middlenames = [ Nothing, Just "Jamesson", Just "Theresa", Just "Ally", Just "Tiberius", Just "Maria" ]
toMatrikel :: [Int] -> [Text]
toMatrikel ns
| (cs, rest) <- splitAt 8 ns
, length cs == 8
= foldMap tshow cs : toMatrikel rest
| otherwise
= []
manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
{ userIdent { userIdent
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
@ -571,8 +583,16 @@ fillDb = do
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
"Jackson" -> "" "Jackson" -> ""
_ -> userIdent _ -> userIdent
-- toMatrikel :: [Int] -> [Text]
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) -- toMatrikel ns
-- | (cs, rest) <- splitAt 10 ns
-- , length cs == 10
-- = foldMap tshow cs : toMatrikel rest
-- | otherwise
-- = []
-- matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
baseMatrikel <- getRandomR (10000 :: Int, 999999 :: Int)
let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699]
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
@ -630,6 +650,11 @@ fillDb = do
ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com" ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com"
bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing
_noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing
randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing | n <- [1001..2002]
, let neven = even n
, let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
, let rcShort = CI.mk $ "RC" <> tshow n
]
void . insert' $ UserCompany jost fraportAg True True void . insert' $ UserCompany jost fraportAg True True
void . insert' $ UserCompany svaupel nice True False void . insert' $ UserCompany svaupel nice True False
void . insert' $ UserCompany gkleen nice False False void . insert' $ UserCompany gkleen nice False False
@ -642,6 +667,13 @@ fillDb = do
insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
insertMany_ [UserCompany uid rckey issuper False
| rckey <- randComps
, Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey]
, Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers
, uSurname /= "Jackson", uSurname /= "Lee"
, let issuper = uSurname == "Wolf"
]
-- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost gkleen True
-- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost svaupel False
-- void . insert' $ UserSupervisor jost sbarth False -- void . insert' $ UserSupervisor jost sbarth False
@ -661,9 +693,9 @@ fillDb = do
, UserSupervisor gkleen gkleen True , UserSupervisor gkleen gkleen True
, UserSupervisor tinaTester tinaTester False , UserSupervisor tinaTester tinaTester False
] ]
++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] ++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost]
++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] ++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ]
++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]
upsertManyWhere supvs [] [] [] upsertManyWhere supvs [] [] []
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error! -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!