110 lines
4.3 KiB
Haskell
110 lines
4.3 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.Map as Map
|
|
|
|
import qualified Database.Esqueleto 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])
|
|
|
|
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 $ 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 = mempty
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, 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
|