889 lines
48 KiB
Haskell
889 lines
48 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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 Handler.Utils
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.Invitations
|
|
import Handler.Utils.Avs
|
|
|
|
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 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 | UserAvsSync
|
|
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
|
|
| UserAvsSyncData
|
|
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 } -> cellHasMatrikelnummerLinkedAdmin entUsr
|
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \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.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
|
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
|
companies =
|
|
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
|
pure $ intercalate (text2widget "; ") companies
|
|
-- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
|
-- (AdminUserR <$> encrypt uid)
|
|
-- (toWgt userCompanyPersonalNumber)
|
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell 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 "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
|
|
-- , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalUser
|
|
-- , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalUser
|
|
, 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
|
|
<ul .list--inline .list--comma-separated>
|
|
$forall (E.Value sh) <- schools
|
|
<li>#{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 UserAvsSync $ pure UserAvsSyncData
|
|
, 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
|
|
-- ) -- TODO: reintroduce via ExternalUser
|
|
, ( "last-login"
|
|
, SortColumn $ \user -> user E.^. UserLastAuthentication
|
|
)
|
|
-- , ( "ldap-sync"
|
|
-- , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
|
|
-- ) -- TODO: reintroduce via ExternalUser
|
|
, ( "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.%))
|
|
)
|
|
, ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
|
|
, ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
|
|
, ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs
|
|
| 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
|
|
-- ) -- TODO: reintroduce via ExternalUser
|
|
, ( "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)
|
|
-- ) -- TODO: reintroduce via ExternalUser
|
|
, ( "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.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
|
|
-- E.from $ \usrAvs -> -- do
|
|
-- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
|
|
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
|
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
|
|
-- )
|
|
, ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
|
|
Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
_ -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
)
|
|
]
|
|
, 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 "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlus)
|
|
, prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer
|
|
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs
|
|
, 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 "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
|
|
, prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
|
|
-- , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalUser
|
|
-- , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalUser
|
|
]
|
|
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
, dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")])
|
|
, 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 = []
|
|
}
|
|
|
|
-- $logInfoS "UsersFormResult" $ tshow usersRes
|
|
formResult usersRes $ \case
|
|
(act, usersSet)
|
|
| Set.null usersSet && isNotSetSupervisor act ->
|
|
addMessageI Info MsgActionNoUsersSelected
|
|
(UserLdapSyncData, userSet) -> do
|
|
forM_ userSet $ queueJob' . JobSynchroniseUser
|
|
addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet
|
|
redirectKeepGetParams UsersR
|
|
(UserAvsSyncData, userSet) -> do
|
|
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing
|
|
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
|
|
redirectKeepGetParams UsersR
|
|
(UserHijack, Set.minView -> Just (uid, _)) ->
|
|
hijackUser uid >>= sendResponse
|
|
(UserRemoveSupervisorData, userSet) -> do
|
|
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
|
|
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
|
|
redirectKeepGetParams 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)
|
|
redirectKeepGetParams UsersR
|
|
_other -> addMessageI Error MsgInvalidFormAction
|
|
|
|
((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
|
|
|
|
formResult allUsersRes $ \case
|
|
AllUsersLdapSync -> do
|
|
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey)
|
|
addMessageI Success MsgSynchroniseUserdbAllUsersQueued
|
|
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) []
|
|
|
|
getAdminHijackUserR :: CryptoUUIDUser -> Handler Html
|
|
getAdminHijackUserR cID = do
|
|
(hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm
|
|
let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID }
|
|
uid :: UserId <- decrypt cID
|
|
usr <- runDB $ get404 uid
|
|
siteLayoutMsg MsgUserHijack $ do
|
|
setTitleI MsgUserHijack
|
|
[whamlet|
|
|
^{userWidget usr}
|
|
^{hjForm}
|
|
|]
|
|
|
|
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
|
postAdminHijackUserR cID = do
|
|
((hijackRes, _), _) <- runFormPost hijackUserForm
|
|
$logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
|
|
uid <- decrypt cID
|
|
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
|
|
| is _Nothing userPasswordHash -> [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 -- TODO: Reformulate messages and constructors to "remove pw hash" or "external login only"
|
|
-- let
|
|
-- ldapHandler :: MonadPlus m => Auth.LdapUserException -> m a
|
|
-- ldapHandler _ = mzero
|
|
-- ldapResult <- runMaybeT . handle ldapHandler $ do
|
|
-- Just pool <- getsYesod $ view _appLdapPool
|
|
-- void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) []
|
|
-- case ldapResult 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
|
|
-- TODO: check current auth sources and warn if user cannot login using any source
|
|
case userPasswordHash of
|
|
Nothing -> addMessageI Error MsgAuthLDAPAlreadyConfigured
|
|
Just _ -> do
|
|
runDBJobs $ do
|
|
update uid [ UserPasswordHash =. Nothing ]
|
|
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
|
|
addMessageI Success MsgAuthLDAPConfigured
|
|
redirect $ AdminUserR uuid
|
|
BtnAuthPWHash -> do
|
|
if
|
|
| is _Just userPasswordHash
|
|
-> addMessageI Info MsgAuthPWHashAlreadyConfigured
|
|
| otherwise
|
|
-> do
|
|
runDBJobs $ do
|
|
update uid [ UserPasswordHash =. Just "" ]
|
|
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 newUserId = do
|
|
res <- try . runDB . setSerializable $ assimilateUser newUserId uid
|
|
case res of
|
|
Left (err :: UserAssimilateException) ->
|
|
addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right
|
|
[whamlet|
|
|
<div .shown>
|
|
#{tshow err}
|
|
|]
|
|
Right warnings -> do
|
|
unless (null warnings) $
|
|
addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right
|
|
[whamlet|
|
|
$newline never
|
|
<ul>
|
|
$forall warning <- warnings
|
|
<li .shown>
|
|
#{tshow warning}
|
|
|]
|
|
addMessageI Success MsgAssimilateUserSuccess
|
|
newUuid <- encrypt newUserId
|
|
redirect $ AdminUserR newUuid
|
|
((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 _Just userPasswordHash)
|
|
, False <$ guard isAdmin
|
|
, do
|
|
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
|
|
unless (authMode `constEq` computeUserAuthenticationDigest userPasswordHash) . lift $
|
|
invalidArgsI [MsgUnauthorizedPasswordResetToken]
|
|
return False
|
|
]
|
|
|
|
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
|
|
currentResult <- if
|
|
| Just (encodeUtf8 -> pwHash) <- userPasswordHash
|
|
, 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 [ UserPasswordHash =. Just 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
|