From 3f52d902c5ea583c081b449e39467f3ab36fe865 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Sun, 14 Apr 2019 19:21:30 +0200 Subject: [PATCH] Mostly working correctly now --- src/Aggreact.hs | 2 +- src/Aggreact/Auth.hs | 63 +++++++++++++++++++++++++---------- src/Aggreact/Authorization.hs | 61 +++++++++++++-------------------- src/Aggreact/Users/Views.hs | 8 +++-- 4 files changed, 76 insertions(+), 58 deletions(-) diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 1a41011..290facf 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -67,7 +67,7 @@ data Conf = type API auths = Auth auths User :> Authenticated - :<|> LoginAPI + :<|> LoginAPI auths type Authenticated = HomepageAPI diff --git a/src/Aggreact/Auth.hs b/src/Aggreact/Auth.hs index 56c001a..cf3c384 100644 --- a/src/Aggreact/Auth.hs +++ b/src/Aggreact/Auth.hs @@ -36,8 +36,9 @@ import Protolude -------------------------------------------------------------------------------- import Aggreact.Html -import Aggreact.Users (NewUser (..), User, UserHandler (..), - checkUserLogin, loginWidget) +import Aggreact.Users (NewUser (..), User, + UserHandler (..), checkUserLogin, + loginWidget) -------------------------------------------------------------------------------- import Data.Aeson @@ -45,9 +46,10 @@ import Database.Store import Servant import Servant.Auth.Server import Servant.Errors -import Servant.HTML.Blaze (HTML) -import qualified Text.Blaze.Html5 as H -import qualified Web.FormUrlEncoded as Form +import Servant.HTML.Blaze (HTML) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Web.FormUrlEncoded as Form data Login = Login { username :: Text @@ -59,20 +61,47 @@ instance FromJSON Login instance Form.FromForm Login where fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} -type LoginAPI = - "login" - :> (ReqBody '[JSON, FormUrlEncoded] Login - :> QueryParam "origin" Text - :> Post '[JSON, HTML] - (Headers '[ Header "Set-Cookie" SetCookie - , Header "Set-Cookie" SetCookie] - LoggedIn) - :<|> Get '[HTML] LoginPage) +type LoginAPI auths = + ("login" :> (ReqBody '[JSON, FormUrlEncoded] Login + :> QueryParam "origin" Text + :> Post '[JSON, HTML] + (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + LoggedIn) + :<|> Get '[HTML] LoginPage)) + :<|> "pre-logout" + :> Auth auths User + :> Get '[HTML] PreLogoutPage + :<|> "logout" + :> Auth auths User + :> Get '[HTML] NoContent -serverLoginAPI :: LoginSettings -> Server LoginAPI +serverLoginAPI :: LoginSettings -> Server (LoginAPI auths) serverLoginAPI loginSettings = - checkCreds loginSettings - :<|> return LoginPage + (checkCreds loginSettings + :<|> return LoginPage) + :<|> preLogout + :<|> logout + +logout :: (ThrowAll (m a)) => AuthResult t -> m a +logout (Authenticated _) = + throwAll $ err302 { errHeaders = [ ("Location", "/") + , ("Set-Cookie", "JWT-Cookie=deleted; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT" ) ] } +logout _ = throwAll err401 + +newtype PreLogoutPage = PreLogoutPage { muser :: Maybe User } + +instance H.ToMarkup PreLogoutPage where + toMarkup PreLogoutPage{..} = + boilerplate (loginWidget muser) $ do + H.p "Are you sure you want to logout?" + H.a H.! A.href "/logout" $ "Yes" + H.text " / " + H.a H.! A.href "/" $ "No" + +preLogout :: AuthResult User -> Handler PreLogoutPage +preLogout (Authenticated u) = pure $ PreLogoutPage (Just u) +preLogout _ = throwAll err401 data LoginSettings = LoginSettings diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index bd5c9eb..8a8943e 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -87,42 +87,9 @@ strToScope txt = "" -> Just Write _ -> Nothing -unloggedScopes :: AuthorizationStrategy -> Scopes -unloggedScopes Anybody = - [ "comment:read" - , "comment:write" - , "slug:read"] - & traverse strToScope - & fmap Set.fromList - & fromMaybe Set.empty - -unloggedScopes LoggedInOnly = - [ "comment:read" - , "slug:read"] - & traverse strToScope - & fmap Set.fromList - & fromMaybe Set.empty - -scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope -scopesFor _ Anybody = - [ "comment:read" - , "comment:write" - , "slug:read"] - & traverse strToScope - & fmap Set.fromList - & fromMaybe Set.empty - -scopesFor u LoggedInOnly = - let scs = case role u of - User -> [ "comment:read" - , "comment:write" - , "slug:read"] - Admin -> [ "comment:read" - , "comment:write" - , "slug:read" - , "slug:write"] - in - scs +txtLstToScopes :: [Text] -> Scopes +txtLstToScopes scs = + scs & traverse strToScope & fmap Set.fromList & fromMaybe Set.empty @@ -130,9 +97,27 @@ scopesFor u LoggedInOnly = scopeToStr :: Scope -> Text scopeToStr (Scope res acc) = res <> case acc of Read -> ":read"; Write -> ":write" +readOnlyScopes :: [Text] +readOnlyScopes = [ "comment:read", "slug:read" ] +commentGrantedScopes :: [Text] +commentGrantedScopes = [ "comment:read", "slug:read" ] +allScopes :: [Text] +allScopes = [ "admin", "comment:read", "comment:write", "slug:read", "slug:write" ] + userScopes' :: AuthorizationStrategy -> Maybe User -> Scopes -userScopes' authStrat Nothing = unloggedScopes authStrat -userScopes' authStrat (Just (Entity _ u _)) = scopesFor u authStrat +userScopes' Anybody Nothing = + txtLstToScopes commentGrantedScopes +userScopes' Anybody (Just (Entity _ NewUser { role = User } _)) = + txtLstToScopes commentGrantedScopes +userScopes' Anybody (Just (Entity _ NewUser { role = Admin } _)) = + txtLstToScopes allScopes + +userScopes' LoggedInOnly Nothing = + txtLstToScopes readOnlyScopes +userScopes' LoggedInOnly (Just (Entity _ NewUser { role = User } _)) = + txtLstToScopes commentGrantedScopes +userScopes' LoggedInOnly (Just (Entity _ NewUser { role = Admin } _)) = + txtLstToScopes allScopes hasScope' :: AuthorizationStrategy -> Scope -> Maybe User -> Bool hasScope' authStrat s u = Set.member s (userScopes' authStrat u) diff --git a/src/Aggreact/Users/Views.hs b/src/Aggreact/Users/Views.hs index 150b656..82de4d3 100644 --- a/src/Aggreact/Users/Views.hs +++ b/src/Aggreact/Users/Views.hs @@ -79,7 +79,7 @@ instance H.ToMarkup UserPage where showScopes :: Scopes -> H.Markup showScopes scopes = H.div $ do H.label "scopes" - H.text (displayScopes scopes) + H.code (H.text (displayScopes scopes)) showUser :: User -> H.Markup showUser user = do @@ -136,7 +136,11 @@ deleteUserById (Just u) userHandler userId loginWidget :: Maybe User -> H.Markup loginWidget Nothing = H.a ! A.href "/login" $ H.text "Login" -loginWidget (Just (Entity _ nu _)) = H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu)) +loginWidget (Just (Entity _ nu _)) = do + H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu)) + H.span ! A.class_ "small" $ do + H.text " / " + H.a ! A.href "/pre-logout" $ "logout" -- List Users data UsersPage =