125 lines
5.2 KiB
Haskell
125 lines
5.2 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Handler.Users where
|
|
|
|
import Import
|
|
-- import Data.Text
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
hijackUserForm :: UserId -> Form UserId
|
|
hijackUserForm uid csrf = do
|
|
cID <- encrypt uid
|
|
(uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
|
|
(btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
|
|
|
|
return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
|
|
|
|
getUsersR :: Handler Html
|
|
getUsersR = do
|
|
let
|
|
colonnadeUsers = dbColonnade . mconcat $
|
|
[ dbRow
|
|
, sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
|
(AdminUserR <$> encrypt uid)
|
|
(toWidget . display $ userDisplayName)
|
|
, 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 _ } -> mempty
|
|
{ dbCellContents = do
|
|
schools <- 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 _ } -> mempty
|
|
{ dbCellContents = do
|
|
schools <- 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
|
|
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
|
|
cID <- encrypt uid
|
|
[whamlet|
|
|
<form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
|
|
^{hijackView}
|
|
|]
|
|
]
|
|
psValidator = def
|
|
& defaultSorting [("display-name", SortAsc)]
|
|
|
|
userList <- dbTable psValidator $ DBTable
|
|
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
|
, dbtColonnade = colonnadeUsers
|
|
, dbtProj = return
|
|
, dbtSorting = Map.fromList
|
|
[ ( "display-name"
|
|
, SortColumn $ \user -> user E.^. UserDisplayName
|
|
)
|
|
, ( "matriculation"
|
|
, SortColumn $ \user -> user E.^. UserMatrikelnummer
|
|
)
|
|
-- , ( "last-name"
|
|
-- , SortColumn $ \user -> (last . impureNonNull . words) <$> (user E.^. UserDisplayName)
|
|
-- )
|
|
]
|
|
, dbtFilter = mempty
|
|
, dbtStyle = def
|
|
, dbtIdent = "users" :: Text
|
|
}
|
|
|
|
defaultLayout $ do
|
|
setTitleI MsgUserListTitle
|
|
$(widgetFile "users")
|
|
|
|
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
|
postAdminHijackUserR cID = do
|
|
uid <- decrypt cID
|
|
((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
|
|
|
|
case hijackRes of
|
|
FormSuccess uid'
|
|
| uid' == uid -> do
|
|
myUid <- requireAuthId
|
|
User{..} <- runDB $ do
|
|
otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
|
|
otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
|
|
mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
|
|
when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
|
|
permissionDenied "Cannot escalate admin status to additional schools"
|
|
|
|
get404 uid
|
|
setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
|
|
| otherwise -> error "This should be impossible by definition of `hijackUserForm`"
|
|
FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs
|
|
FormMissing -> return $ toTypedContent ()
|