-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Users ( module Handler.Users ) where import Import import Jobs -- import Data.Text import Handler.Utils import Handler.Utils.Users import Handler.Utils.Invitations import Handler.Utils.Avs import qualified Auth.LDAP as Auth import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Profile (makeProfileData) import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Data.ByteString.Base64 as Base64 import Data.Aeson hiding (Result(..)) -- import Handler.Users.Add as Handler.Users import qualified Data.Conduit.List as C import qualified Data.HashSet as HashSet import Auth.Dummy (apDummy) hijackUserForm :: Form () hijackUserForm csrf = do (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView]) -- In case of refactoring, use this: -- instance HasEntity (DBRow (Entity User)) User where -- hasEntity = _dbrOutput -- instance HasUser (DBRow (Entity USer)) where -- hasUser = _entityVal data UserAction = UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id data UserActionData = UserLdapSyncData | UserHijack | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } | UserRemoveSupervisorData deriving (Eq, Ord, Read, Show, Generic) isNotSetSupervisor :: UserActionData -> Bool isNotSetSupervisor UserSetSupervisorData{} = False isNotSetSupervisor _ = True isActionSupervisor :: UserActionData -> Bool isActionSupervisor UserAddSupervisorData{} = True isActionSupervisor UserSetSupervisorData{} = True isActionSupervisor _ = False data AllUsersAction = AllUsersLdapSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''AllUsersAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AllUsersAction id instance Button UniWorX AllUsersAction where btnClasses _ = [BCIsButton, BCPrimary] getUsersR, postUsersR :: Handler Html getUsersR = postUsersR postUsersR = do MsgRenderer mr <- getMsgRenderer let dbtColonnade = mconcat [ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey)) , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let companies = intersperse (text2markup ", ") $ (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (toWgt userCompanyPersonalNumber) , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) , sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) let supervisors = intersperse (text2widget ", ") $ (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' icnReroute = text2widget " " <> toWgt (icon IconLetter) pure $ mconcat supervisors , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function E.orderBy [E.asc $ school E.^. SchoolShorthand] return $ school E.^. SchoolShorthand return [whamlet| $newline never
    $forall (E.Value sh) <- schools
  • #{sh} |] , sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } -> let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ] in listCell' getFunctions i18nCell , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell { formCellAttrs = [] , formCellLens = id , formCellContents = do cID <- encrypt uid mayHijack <- lift . lift $ (== Authorized) <$> evalAccess (AdminHijackUserR cID) True myUid <- liftHandler maybeAuthId if | mayHijack , Just uid /= myUid -> lift $ do let postprocess :: FormResult () -> FormResult (First UserActionData, DBFormResult UserId Bool (DBRow (Entity User))) postprocess (FormSuccess ()) = FormSuccess (First $ Just UserHijack, DBFormResult $ Map.singleton uid (inp, const True)) postprocess FormMissing = FormSuccess mempty postprocess (FormFailure errs) = FormFailure errs over _1 postprocess <$> hijackUserForm mempty | otherwise -> return mempty } ] psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "display-name"] (usersRes, userList) <- runDB $ do schoolOptions <- map (CI.original . schoolName . entityVal &&& CI.original . unSchoolKey . entityKey) <$> selectList [] [Asc SchoolName] let postprocess :: FormResult (First UserActionData, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (UserActionData, Set UserId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) acts :: Map UserAction (AForm Handler UserActionData) acts = mconcat [ singletonMap UserLdapSync $ pure UserLdapSyncData , singletonMap UserAddSupervisor $ UserAddSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserSetSupervisor $ UserSetSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData ] over _1 postprocess <$> dbTable psValidator DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) , dbtRowKey = (E.^. UserId) , dbtColonnade , dbtProj = dbtProjId , dbtSorting = Map.fromList $ [ ( SortingKey $ CI.mk $ toPathPiece function , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do E.where_ $ uf E.^. UserFunctionUser E.==. user E.^. UserId E.&&. uf E.^. UserFunctionFunction E.==. E.val function return (uf E.^. UserFunctionSchool) ) | function <- universeF ] ++ [ ( "name" , SortColumn $ \user -> user E.^. UserSurname ) , ( "display-name" , SortColumn $ \user -> user E.^. UserDisplayName ) , ( "matriculation" , SortColumn $ \user -> user E.^. UserMatrikelnummer ) , ( "personal-number" , SortColumn $ \user -> user E.^. UserCompanyPersonalNumber ) , ( "company-department" , SortColumn $ \user -> user E.^. UserCompanyDepartment ) , ( "auth-ldap" , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP ) , ( "ldap-sync" , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation ) , ( "user-company" , SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) , ( "user-supervisor" , SortColumn $ \user -> E.subSelect $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId E.where_ $ spvr E.^. UserSupervisorUser E.==. user E.^. UserId E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] return (usrSpvr E.^. UserDisplayName) ) , ( "system-function" , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do E.where_ $ usf E.^. UserSystemFunctionUser E.==. user E.^. UserId return $ usf E.^. UserSystemFunctionFunction ) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) -> if Set.null criteria then E.true else -- TODO: why is this condition not needed? -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text) E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria ) , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) ) , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria ) , ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria ) , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if | Just crit <- getLast criterion -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit | otherwise -> E.true ) , ( "school", FilterColumn $ \user criterion -> if | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> let schools = E.valList (Set.toList criterion) in E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools ) , ( "ldap-sync", FilterColumn $ \user criteria -> if | Just criteria' <- fromNullable criteria -> let minTime = minimum (criteria' :: NonNull (Set UTCTime)) in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation | otherwise -> E.val True :: E.SqlExpr (E.Value Bool) ) , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.^. UserId E.&&. testcrit ) , ( "user-supervisor", FilterColumn $ \user criteria -> if | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> E.exists . E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) ) , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^.UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) ) ] , dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute UsersR , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } , dbtIdent = "users" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] } formResult usersRes $ \case (act, usersSet) | Set.null usersSet && isNotSetSupervisor act -> do addMessageI Info MsgActionNoUsersSelected redirect UsersR (UserLdapSyncData, userSet) -> do runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirect UsersR (UserHijack, Set.minView -> Just (uid, _)) -> hijackUser uid >>= sendResponse (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet redirect UsersR (act, usersSet) | isActionSupervisor act -> do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers users = Set.toList usersSet nrSuperNotFound = length supersNotFound runDB $ do unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users] putMany [UserSupervisor s u r | let r = getActionRerouteNotifications act , (_, Just s) <- supersFound , u <- users ] if nrSuperNotFound > 0 then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) redirect UsersR _other -> error "Should not be possible" ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm formResult allUsersRes $ \case AllUsersLdapSync -> do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR let allUsersWgt' = wrapForm allUsersWgt def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute UsersR , formEncoding = allUsersEnctype } defaultLayout $ do setTitleI MsgUserListTitle $(widgetFile "users") hijackUser :: UserId -> Handler TypedContent hijackUser uid = do User{userIdent} <- runDB $ get404 uid setCredsRedirect $ Creds apDummy (CI.original userIdent) [] postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent postAdminHijackUserR cID = do uid <- decrypt cID ((hijackRes, _), _) <- runFormPost hijackUserForm ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid maybe (redirect UsersR) return ret data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) instance Universe ButtonAuthMode instance Finite ButtonAuthMode nullaryPathPiece ''ButtonAuthMode $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonAuthMode id instance Button UniWorX ButtonAuthMode where btnClasses _ = [BCIsButton] data UserAssimilateButton = BtnUserAssimilate deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) instance Button UniWorX UserAssimilateButton where btnClasses _ = [BCIsButton, BCPrimary] nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''UserAssimilateButton id getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR = postAdminUserR postAdminUserR uuid = do adminId <- requireAuthId uid <- decrypt uuid (user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do user <- get404 uid schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do E.on $ userFunction E.?. UserFunctionSchool E.==. E.just (school E.^. SchoolId) E.&&. userFunction E.?. UserFunctionUser E.==. E.just (E.val uid) let isAdmin = E.exists . E.from $ \adminFunction -> E.where_ $ adminFunction E.^. UserFunctionUser E.==. E.val adminId E.&&. adminFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin return (school, userFunction E.?. UserFunctionFunction, isAdmin) systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] [] let systemFunctions = (`Set.member` systemFunctionsF) return ( user , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools , setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools , setOf (folded . _1) schools , systemFunctions ) let allFunctions = Set.fromList universeF allSchools = Set.mapMonotonic entityKey schools -- above data is needed for both form generation and result evaluation let userRightsForm :: Form (Set (SchoolFunction, SchoolId)) userRightsForm csrf = do boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if | sid `Set.member` adminSchools -> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions | otherwise -> mforced checkBoxField "" $ (function, sid) `Set.member` functions let result = Map.keysSet . Map.filter id <$> mapM (view _1) boxRights return (result, $(widgetFile "widgets/user-rights-form/user-rights-form")) userAuthenticationForm :: Form ButtonAuthMode userAuthenticationForm = buttonForm' $ if | userAuthentication == AuthLDAP -> [BtnAuthPWHash] | otherwise -> [BtnAuthLDAP, BtnPasswordReset] systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func let userRightsAction changes = do let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes) updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff if | not $ Set.null updates -> runDBJobs $ do $logInfoS "user-rights-update" $ tshow updates forM_ (setOf (folded . _1) updates) $ \func -> memcachedByInvalidate (AuthCacheSchoolFunctionList func) $ Proxy @(Set UserId) forM_ updates $ \(function, sid) -> do $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|] if | (function, sid) `Set.member` changes -> void . insertUnique $ UserFunction uid sid function | otherwise -> deleteBy $ UniqueUserFunction uid sid function queueDBJob . JobQueueNotification . NotificationUserRightsUpdate uid $ Set.mapMonotonic (over _2 unSchoolKey) functions -- original rights to check for difference addMessageI Success MsgAccessRightsSaved | otherwise -> addMessageI Info MsgAccessRightsNotChanged redirect $ AdminUserR uuid userAuthenticationAction = \case BtnAuthLDAP -> do let campusHandler :: MonadPlus m => Auth.CampusUserException -> m a campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do Just pool <- getsYesod $ view _appLdapPool void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) [] case campusResult of Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup _other | is _AuthLDAP userAuthentication -> addMessageI Info MsgAuthLDAPAlreadyConfigured Just () -> do runDBJobs $ do update uid [ UserAuthentication =. AuthLDAP ] queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid addMessageI Success MsgAuthLDAPConfigured redirect $ AdminUserR uuid BtnAuthPWHash -> do if | is _AuthPWHash userAuthentication -> addMessageI Info MsgAuthPWHashAlreadyConfigured | otherwise -> do runDBJobs $ do update uid [ UserAuthentication =. AuthPWHash "" ] queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid queueDBJob $ JobSendPasswordReset uid addMessageI Success MsgAuthPWHashConfigured redirect $ AdminUserR uuid BtnPasswordReset -> do queueJob' $ JobSendPasswordReset uid addMessageI Success MsgPasswordResetQueued redirect $ AdminUserR uuid userSystemFunctionsAction newFuncs = do let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions if | not $ Set.null symmDiff -> runDBJobs $ do forM_ symmDiff $ \func -> do memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) if | newFuncs func -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ] | otherwise -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ] queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions addMessageI Success MsgUserSystemFunctionsSaved | otherwise -> addMessageI Info MsgUserSystemFunctionsNotChanged redirect $ AdminUserR uuid let assimilateForm' = renderAForm FormStandard $ areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing assimilateAction oldUserId = do res <- try . runDB . setSerializable $ assimilateUser uid oldUserId case res of Left (err :: UserAssimilateException) -> addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right [whamlet|
    #{tshow err} |] Right warnings -> do unless (null warnings) $ addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right [whamlet| $newline never
      $forall warning <- warnings
    • #{tshow warning} |] addMessageI Success MsgAssimilateUserSuccess redirect $ AdminUserR uuid ((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm ((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm ((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' ((assimilateFormResult, assimilateFormWidget), assimilateFormEnctype) <- runFormPost $ identifyForm FIDUserAssimilate assimilateForm' let rightsForm = wrapForm rightsFormWidget def { formAction = Just . SomeRoute $ AdminUserR uuid , formEncoding = rightsFormEnctype } authForm = wrapForm authFormWidget def { formAction = Just . SomeRoute $ AdminUserR uuid , formEncoding = authFormEnctype , formSubmit = FormNoSubmit } systemFunctionsForm = wrapForm systemFunctionsWidget def { formAction = Just . SomeRoute $ AdminUserR uuid , formEncoding = systemFunctionsEnctype } assimilateForm = wrapForm' BtnUserAssimilate assimilateFormWidget def { formAction = Just . SomeRoute $ AdminUserR uuid , formEncoding = assimilateFormEnctype } formResult rightsResult userRightsAction formResult authResult userAuthenticationAction formResult systemFunctionsResult userSystemFunctionsAction formResult assimilateFormResult assimilateAction let heading = [whamlet|_{MsgAdminUserHeadingFor} ^{userEmailWidget user}|] -- Delete Button needed in data-delete (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) let deleteForm = wrapForm deleteWgt def { formAction = Just $ SomeRoute $ AdminUserDeleteR uuid , formEncoding = deleteEnctype , formSubmit = FormNoSubmit } userDataWidget <- runDB $ makeProfileData $ Entity uid user siteLayout heading $ do let _deleteWidget = $(i18nWidgetFile "data-delete") $(widgetFile "adminUser") postAdminUserDeleteR :: CryptoUUIDUser -> Handler Html postAdminUserDeleteR uuid = do uid <- decrypt uuid ((btnResult,_), _) <- runFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) case btnResult of (FormSuccess BtnDelete) -> do User{..} <- runDB $ get404 uid -- clearCreds False -- Logout-User ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid -- addMessageIHamlet $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE -- addMessageI Success $ MsgDeleteUser deletedSubmissions -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions defaultLayout $(widgetFile "deletedUser") -- (FormSuccess BtnAbort ) -> do -- addMessageI Info MsgAborted -- redirect ProfileDataR _other -> getAdminUserR uuid deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration deleteUser duid = do -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually -- We delete all files tied to submissions where the user is the lone submissionUser -- Do not deleteCascade submissions where duid is the corrector: updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing] groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) delete duid -- cascade is now defined in models files; therefor does not cascade at all currently (2021-06-27); not even SubmissionUser... forM_ singleSubmissions $ \(E.Value submissionId) -> do delete submissionId -- ditto deletedSubmissionGroups <- deleteSingleSubmissionGroups return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) where selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)] selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission let numBuddies = E.subSelectCount $ E.from $ \subUsers -> E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid E.&&. whereBuddies numBuddies return $ submission E.^. SubmissionId deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do E.where_ $ E.exists $ E.from $ \subGroupUser -> E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid E.where_ $ E.notExists $ E.from $ \subGroupUser -> E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid getUserPasswordR, postUserPasswordR :: CryptoUUIDUser -> Handler Html getUserPasswordR = postUserPasswordR postUserPasswordR cID = do tUid <- decrypt cID usr@User{..} <- runDB $ get404 tUid PWHashConf{..} <- getsYesod $ view _appAuthPWHash isModal <- hasCustomHeader HeaderIsModal isAdmin <- hasWriteAccessTo $ AdminUserR cID requireCurrent <- maybeT (return True) $ asum [ False <$ guard (isn't _AuthPWHash userAuthentication) , False <$ guard isAdmin , do authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $ invalidArgsI [MsgUnauthorizedPasswordResetToken] return False ] ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do currentResult <- if | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication , requireCurrent -> wreq (checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField) (fslI MsgCurrentPassword & addAttr "autocomplete" "current-password") Nothing | otherwise -> return $ FormSuccess () newResult <- do resA <- wreq passwordField (fslI MsgNewPassword & addAttr "autocomplete" "new-password") Nothing wreq (checkBool ((== resA) . FormSuccess) MsgPasswordRepeatInvalid passwordField) (fslI MsgNewPasswordRepeat & addAttr "autocomplete" "new-password") Nothing return . fmap encodeUtf8 $ currentResult *> newResult formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] tell . pure =<< messageI Success MsgPasswordChangedSuccess siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $ wrapForm passFormWidget def { formAction = Just . SomeRoute $ UserPasswordR cID , formEncoding = passEnctype , formAttrs = [ asyncSubmitAttr | isModal ] } instance IsInvitableJunction UserFunction where type InvitationFor UserFunction = School data InvitableJunction UserFunction = JunctionUserFunction { jFunction :: SchoolFunction } deriving (Eq, Ord, Read, Show, Generic) data InvitationDBData UserFunction = InvDBDataUserFunction { invDBUserFunctionDeadline :: UTCTime } deriving (Eq, Ord, Read, Show, Generic) data InvitationTokenData UserFunction = InvTokenDataUserFunction { invTokenUserFunctionSchool :: SchoolShorthand , invTokenUserFunctionFunction :: SchoolFunction } deriving (Eq, Ord, Read, Show, Generic) _InvitableJunction = iso (\UserFunction{..} -> (userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction)) (\(userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction) -> UserFunction{..}) instance ToJSON (InvitableJunction UserFunction) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 } instance FromJSON (InvitableJunction UserFunction) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 } instance ToJSON (InvitationDBData UserFunction) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance FromJSON (InvitationDBData UserFunction) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance ToJSON (InvitationTokenData UserFunction) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance FromJSON (InvitationTokenData UserFunction) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } functionInvitationConfig :: InvitationConfig UserFunction functionInvitationConfig = InvitationConfig{..} where invitationRoute _ _ = return AdminFunctionaryInviteR invitationResolveFor InvTokenDataUserFunction{..} = return $ SchoolKey invTokenUserFunctionSchool invitationSubject (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage . MsgMailSubjectSchoolFunctionInvitation schoolName $ mr invTokenUserFunctionFunction invitationHeading (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage . MsgMailSchoolFunctionInviteHeading schoolName $ mr invTokenUserFunctionFunction invitationExplanation _ (_, InvTokenDataUserFunction{..}) = do MsgRenderer mr <- getMsgRenderer return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|] invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId let itExpiresAt = Just $ Just invDBUserFunctionDeadline itAddAuth = Nothing itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ()) invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction invitationUltDest (Entity ssh _) _ = do currentTerm <- getCurrentTerm return . SomeRoute $ case currentTerm of Just tid -> TermSchoolCourseListR tid ssh _other -> CourseListR getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR postAdminNewFunctionaryInviteR = do uid <- requireAuthId userSchools <- runDB . E.select . E.from $ \userAdmin -> do E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin return $ userAdmin E.^. UserFunctionSchool ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do now <- liftIO getCurrentTime let localNow = utcToLocalTime now beginToday = case localTimeToUTC (LocalTime (localDay localNow) midnight) of LTUUnique utc' _ -> utc' _other -> UTCTime (utctDay now) 0 defDeadline = beginToday{ utctDay = 14 `addDays` utctDay beginToday } mr <- getMessageRender function <- wreq (selectField optionsFinite) (fslI MsgFunctionaryInviteFunction) Nothing school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgFunctionaryInviteSchool) Nothing deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline) users <- wreq (multiUserField False Nothing) (fslpI MsgFunctionaryInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing return $ (,,,) <$> function <*> school <*> deadline <*> users formResultModal invitesResult UsersR $ \(function, schoolId, deadline, users) -> do let (emails, uids) = partitionEithers $ Set.toList users lift . runDBJobs $ do forM_ uids $ \lecId -> void . insertUnique $ UserFunction lecId schoolId function sinkInvitationsF functionInvitationConfig [ (mail, schoolId, (InvDBDataUserFunction deadline, InvTokenDataUserFunction (unSchoolKey schoolId) function)) | mail <- emails ] unless (null emails) $ tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails unless (null uids) $ tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids siteLayoutMsg MsgFunctionaryInviteHeading $ do setTitleI MsgFunctionaryInviteHeading wrapForm invitesWgt def { formEncoding = invitesEncoding , formAction = Just $ SomeRoute AdminNewFunctionaryInviteR } getAdminFunctionaryInviteR, postAdminFunctionaryInviteR :: Handler Html getAdminFunctionaryInviteR = postAdminFunctionaryInviteR postAdminFunctionaryInviteR = invitationR functionInvitationConfig