diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 8dd3422..1a41011 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -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 diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index 9a48bb5..bd5c9eb 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -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 diff --git a/src/Aggreact/Servant/Errors.hs b/src/Aggreact/Servant/Errors.hs index 323441c..4f06a0c 100644 --- a/src/Aggreact/Servant/Errors.hs +++ b/src/Aggreact/Servant/Errors.hs @@ -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 diff --git a/src/Aggreact/Users/Server.hs b/src/Aggreact/Users/Server.hs index 88aa56a..d5f8c0d 100644 --- a/src/Aggreact/Users/Server.hs +++ b/src/Aggreact/Users/Server.hs @@ -42,18 +42,19 @@ where import Protolude +import Aggreact.Authorization (AuthorizationHandler (..)) import Aggreact.Users.StoreService import Aggreact.Users.Types import Aggreact.Users.Views -import Database.SQLite.Simple (NamedParam (..)) +import Database.SQLite.Simple (NamedParam (..)) import Database.Store -import Database.Store.Backend.SQLite (SearchQuery (Filter)) -import qualified Database.Store.Backend.SQLite as SQL +import Database.Store.Backend.SQLite (SearchQuery (Filter)) +import qualified Database.Store.Backend.SQLite as SQL import Servant -import Servant.Auth.Server (AuthResult (..)) -import Servant.Errors as Err -import Servant.HTML.Blaze (HTML) +import Servant.Auth.Server (AuthResult (..)) +import Servant.Errors as Err +import Servant.HTML.Blaze (HTML) -- * User API @@ -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))) diff --git a/src/Aggreact/Users/Views.hs b/src/Aggreact/Users/Views.hs index 95e3dda..150b656 100644 --- a/src/Aggreact/Users/Views.hs +++ b/src/Aggreact/Users/Views.hs @@ -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