add scopes to user page
This commit is contained in:
parent
0b499caae4
commit
b79d5e6eeb
5 changed files with 34 additions and 18 deletions
|
@ -82,7 +82,7 @@ serverAuthenticated Settings{..} authresult =
|
|||
homepageAPI commentHandler authresult
|
||||
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
|
||||
:<|> slugAPI (Aggreact.Slugs.Handlers userHandler slugHandler authorizationHandler) authresult
|
||||
:<|> userAPI userHandler authresult
|
||||
:<|> userAPI userHandler authorizationHandler authresult
|
||||
|
||||
data Settings =
|
||||
Settings { cookieSettings :: CookieSettings
|
||||
|
|
|
@ -37,7 +37,7 @@ import Protolude
|
|||
import Aggreact.Scopes (Access (..), Scope (..), Scopes,
|
||||
displayScope, displayScopes)
|
||||
import Aggreact.Servant.Errors (forbidden)
|
||||
import Aggreact.Users (NewUser (..), Role (..), User)
|
||||
import Aggreact.Users.Types (NewUser (..), Role (..), User)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
|
|
|
@ -19,7 +19,8 @@
|
|||
module Aggreact.Servant.Errors where
|
||||
|
||||
import Aggreact.Html (boilerplate)
|
||||
import Aggreact.Users (User, loginWidget)
|
||||
import Aggreact.Users.Types (User)
|
||||
import Aggreact.Users.Views (loginWidget)
|
||||
|
||||
import Network.HTTP.Types (hContentType)
|
||||
import Protolude
|
||||
|
|
|
@ -42,6 +42,7 @@ where
|
|||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.Authorization (AuthorizationHandler (..))
|
||||
import Aggreact.Users.StoreService
|
||||
import Aggreact.Users.Types
|
||||
import Aggreact.Users.Views
|
||||
|
@ -65,32 +66,38 @@ type UserAPI =
|
|||
:> PostCreated '[HTML,JSON] RegisteredUserPage
|
||||
|
||||
userAPI :: UserHandler
|
||||
-- -> AuthorizationHandler
|
||||
-> AuthorizationHandler
|
||||
-> AuthResult User
|
||||
-> Server UserAPI
|
||||
userAPI userHandler authResult =
|
||||
userAPI userHandler authHandler authResult =
|
||||
let muser = case authResult of
|
||||
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
in
|
||||
getUserByNick muser userHandler
|
||||
getUserByNick muser userHandler authHandler
|
||||
:<|> deleteUserById muser userHandler
|
||||
:<|> listUsers muser userHandler
|
||||
:<|> postUser muser userHandler
|
||||
|
||||
-- GET User
|
||||
getUserByNick :: Maybe User -> UserHandler -> Nick -> Handler UserPage
|
||||
getUserByNick muser userHandler userNick = do
|
||||
getUserByNick :: Maybe User
|
||||
-> UserHandler
|
||||
-> AuthorizationHandler
|
||||
-> Nick
|
||||
-> Handler UserPage
|
||||
getUserByNick muser userHandler AuthorizationHandler{..} userNick = do
|
||||
SQL.SR (SQL.Paginated mu _ _) <- liftIO $
|
||||
searchUsers userHandler Filter {params = ["nick" := userNick]}
|
||||
case mu of
|
||||
[] -> Err.notFound "user not found"
|
||||
[u] -> pure (UserPage u muser)
|
||||
[u] -> do
|
||||
let scopes = userScopes (Just u)
|
||||
return (UserPage u muser scopes)
|
||||
_ -> Err.internalServerError "Incoherent DB"
|
||||
|
||||
getUserById :: Maybe User -> UserHandler -> Id -> Handler UserPage
|
||||
getUserById muser userHandler userId = do
|
||||
getUserById :: Maybe User -> UserHandler -> AuthorizationHandler -> Id -> Handler UserPage
|
||||
getUserById muser userHandler AuthorizationHandler{..} userId = do
|
||||
mu <- liftIO $ readUser userHandler userId
|
||||
case mu of
|
||||
Nothing -> Err.notFound "user not found"
|
||||
Just u -> pure (UserPage u muser)
|
||||
Just u -> pure (UserPage u muser (userScopes (Just u)))
|
||||
|
|
|
@ -43,6 +43,7 @@ where
|
|||
import Protolude
|
||||
|
||||
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
||||
import Aggreact.Scopes
|
||||
import Aggreact.Users.StoreService
|
||||
import Aggreact.Users.Types
|
||||
|
||||
|
@ -61,6 +62,7 @@ data UserPage =
|
|||
UserPage
|
||||
{ user :: User
|
||||
, muser :: Maybe User
|
||||
, scopes :: Scopes
|
||||
}
|
||||
|
||||
instance ToJSON UserPage where
|
||||
|
@ -72,6 +74,12 @@ instance H.ToMarkup UserPage where
|
|||
H.h2 $
|
||||
H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
|
||||
showUser user
|
||||
showScopes scopes
|
||||
|
||||
showScopes :: Scopes -> H.Markup
|
||||
showScopes scopes = H.div $ do
|
||||
H.label "scopes"
|
||||
H.text (displayScopes scopes)
|
||||
|
||||
showUser :: User -> H.Markup
|
||||
showUser user = do
|
||||
|
|
Loading…
Reference in a new issue