206 lines
9.7 KiB
Haskell
206 lines
9.7 KiB
Haskell
module Handler.Users where
|
|
|
|
import Import
|
|
-- 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
|
|
|
|
|
|
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|
|
|
<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|
|
|
<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
|
|
[whamlet|
|
|
<form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
|
|
^{hijackView}
|
|
|]
|
|
]
|
|
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 (searchField True) (fslI MsgName)
|
|
-- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt (searchField False) (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)
|
|
(User{..}, fromSchoolList -> adminSchools, 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 csrf = do
|
|
boxRights <- forM userRights $ \(school@(Entity sid _), E.Value isAdmin, E.Value 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
|
|
addMessageI Info MsgAccessRightsSaved
|
|
((result, formWidget),formEnctype) <- runFormPost userRightsForm
|
|
formResult result userRightsAction
|
|
let heading =
|
|
[whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
|
|
siteLayout heading
|
|
$(widgetFile "adminUser")
|