301 lines
15 KiB
Haskell
301 lines
15 KiB
Haskell
module Handler.Users where
|
|
|
|
import Import
|
|
|
|
import Jobs
|
|
-- import Data.Text
|
|
import Handler.Utils
|
|
|
|
import Utils.Lens
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Handler.Profile (makeProfileData)
|
|
|
|
|
|
hijackUserForm :: CryptoUUIDUser -> Form ()
|
|
hijackUserForm cID csrf = do
|
|
(uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
|
|
(btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
|
|
return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
|
|
|
|
-- In case of refactoring, use this:
|
|
-- instance HasEntity (DBRow (Entity User)) User where
|
|
-- hasEntity = _dbrOutput
|
|
-- instance HasUser (DBRow (Entity USer)) where
|
|
-- hasUser = _entityVal
|
|
|
|
getUsersR :: Handler Html
|
|
getUsersR = do
|
|
let
|
|
dbtColonnade = dbColonnade . mconcat $
|
|
[ dbRow
|
|
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
|
(AdminUserR <$> encrypt uid)
|
|
(nameWidget userDisplayName userSurname)
|
|
, sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
|
(AdminUserR <$> encrypt uid)
|
|
(toWidget . display $ userMatrikelnummer)
|
|
-- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
|
-- (AdminUserR <$> encrypt uid)
|
|
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
|
|
, sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
|
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
|
|
E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
|
|
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
|
|
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 Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
|
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
|
|
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
|
|
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
|
|
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 Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
|
|
cID <- encrypt uid
|
|
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
|
myUid <- liftHandlerT maybeAuthId
|
|
when (mayHijack && Just uid /= myUid) $ do
|
|
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
|
|
wrapForm hijackView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AdminHijackUserR cID
|
|
, formEncoding = hijackEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
]
|
|
psValidator = def
|
|
& defaultSorting [SortAscBy "name", SortAscBy "display-name"]
|
|
|
|
((), userList) <- runDB $ do
|
|
schoolOptions <- map (CI.original . schoolName . entityVal &&& CI.original . unSchoolKey . entityKey)
|
|
<$> selectList [] [Asc SchoolName]
|
|
|
|
dbTable psValidator DBTable
|
|
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
, dbtRowKey = (E.^. UserId)
|
|
, dbtColonnade
|
|
, dbtProj = return
|
|
, dbtSorting = Map.fromList
|
|
[ ( "name"
|
|
, SortColumn $ \user -> user E.^. UserSurname
|
|
)
|
|
, ( "display-name"
|
|
, SortColumn $ \user -> user E.^. UserDisplayName
|
|
)
|
|
, ( "matriculation"
|
|
, SortColumn $ \user -> user E.^. UserMatrikelnummer
|
|
)
|
|
]
|
|
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
|
|
[ ( "user-search", FilterColumn $ \user criterion ->
|
|
if Set.null criterion 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 (user E.^. UserDisplayName `E.hasInfix`) criterion
|
|
)
|
|
, ( "matriculation", FilterColumn $ \user (criterion :: Set.Set Text) -> if
|
|
| Set.null criterion -> E.true -- TODO: why can this be eFalse and work still?
|
|
| otherwise -> E.any (user E.^. UserMatrikelnummer `E.hasInfix`) criterion
|
|
)
|
|
, ( "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 $ \ulectr -> do
|
|
E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId
|
|
E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools
|
|
) E.||.
|
|
E.exists ( E.from $ \uadmin -> do
|
|
E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId
|
|
E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools
|
|
)
|
|
)
|
|
]
|
|
, dbtFilterUI = \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
|
|
-- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgMatrikelNr)
|
|
, prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (fslI MsgMatrikelNr)
|
|
|
|
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
|
|
]
|
|
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
, dbtParams = def
|
|
, dbtIdent = "users" :: Text
|
|
}
|
|
|
|
defaultLayout $ do
|
|
setTitleI MsgUserListTitle
|
|
$(widgetFile "users")
|
|
|
|
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
|
postAdminHijackUserR cID = do
|
|
uid <- decrypt cID
|
|
((hijackRes, _), _) <- runFormPost $ hijackUserForm cID
|
|
|
|
ret <- formResultMaybe hijackRes $ \() -> Just <$> do
|
|
User{userIdent} <- runDB $ get404 uid
|
|
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
|
|
|
|
maybe (redirect UsersR) return ret
|
|
|
|
|
|
getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
|
|
getAdminUserR = postAdminUserR
|
|
postAdminUserR uuid = do
|
|
adminId <- requireAuthId
|
|
uid <- decrypt uuid
|
|
let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
|
|
let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer)
|
|
(user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
|
|
<$> get404 uid
|
|
<*> selectList [UserAdminUser ==. adminId] []
|
|
<*> E.select ( E.from $ \school -> do
|
|
E.orderBy [E.asc $ school E.^. SchoolName]
|
|
let schAdmin = E.exists $ E.from $ \userAdmin -> do
|
|
E.where_ $ userAdmin E.^. UserAdminSchool E.==. school E.^. SchoolId
|
|
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
|
|
let schLecturer = E.exists $ E.from $ \userLecturer -> do
|
|
E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
|
|
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
|
|
return (school,schAdmin,schLecturer)
|
|
)
|
|
-- above data is needed for both form generation and result evaluation
|
|
let userRightsForm :: Form [(SchoolId, Bool, Bool)]
|
|
userRightsForm = identifyForm FIDuserRights $ \csrf -> do
|
|
boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) ->
|
|
if Set.member sid adminSchools
|
|
then do
|
|
cbAdmin <- mreq checkBoxField "" (Just isAdmin)
|
|
cbLecturer <- mreq checkBoxField "" (Just isLecturer)
|
|
return (school, cbAdmin, cbLecturer)
|
|
else do
|
|
cbAdmin <- mforced checkBoxField "" isAdmin
|
|
cbLecturer <- mforced checkBoxField "" isLecturer
|
|
return (school, cbAdmin, cbLecturer)
|
|
let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
|
|
(,,) <$> pure sid <*> resAdmin <*> resLecturer
|
|
return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
|
|
let userRightsAction changes = do
|
|
void . runDB $
|
|
forM changes $ \(sid, userAdmin, userLecturer) ->
|
|
if Set.notMember sid adminSchools
|
|
then return ()
|
|
else do
|
|
if userAdmin
|
|
then void . insertUnique $ UserAdmin uid sid
|
|
else deleteBy $ UniqueUserAdmin uid sid
|
|
if userLecturer
|
|
then void . insertUnique $ UserLecturer uid sid
|
|
else deleteBy $ UniqueSchoolLecturer uid sid
|
|
-- Note: deleteWhere would not work well here since we filter by adminSchools
|
|
queueJob' . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
|
|
addMessageI Info MsgAccessRightsSaved
|
|
((result, formWidget),formEnctype) <- runFormPost userRightsForm
|
|
let form = wrapForm formWidget def
|
|
{ formAction = Just . SomeRoute $ AdminUserR uuid
|
|
, formEncoding = formEnctype
|
|
}
|
|
formResult result userRightsAction
|
|
let heading =
|
|
[whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
|
|
-- Delete Button needed in data-delete
|
|
(btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
|
|
let btnForm = wrapForm btnWgt def
|
|
{ formAction = Just $ SomeRoute $ AdminUserDeleteR uuid
|
|
, formEncoding = btnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
userDataWidget <- runDB $ makeProfileData $ Entity uid user
|
|
siteLayout heading $ do
|
|
let deleteWidget = $(widgetFile "widgets/data-delete/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))
|
|
deleteCascade duid
|
|
forM_ singleSubmissions $ \(E.Value submissionId) -> do
|
|
deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId
|
|
deleteCascade submissionId
|
|
deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
|
|
|
|
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.sub_select $ E.from $ \subUsers -> do
|
|
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
|
|
return E.countRows
|
|
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
|
|
E.&&. whereBuddies numBuddies
|
|
return $ submission E.^. SubmissionId
|
|
|
|
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
|
|
getSubmissionFiles subId = E.select $ E.from $ \file -> do
|
|
E.where_ $ E.exists $ E.from $ \submissionFile ->
|
|
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
|
|
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
|
|
return $ file E.^. FileId
|
|
|
|
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
|
|
|