Mostly working correctly now
This commit is contained in:
parent
b79d5e6eeb
commit
3f52d902c5
4 changed files with 76 additions and 58 deletions
|
@ -67,7 +67,7 @@ data Conf =
|
|||
|
||||
type API auths =
|
||||
Auth auths User :> Authenticated
|
||||
:<|> LoginAPI
|
||||
:<|> LoginAPI auths
|
||||
|
||||
type Authenticated =
|
||||
HomepageAPI
|
||||
|
|
|
@ -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
|
||||
|
@ -47,6 +48,7 @@ import Servant.Auth.Server
|
|||
import Servant.Errors
|
||||
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
|
||||
|
@ -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
|
||||
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)
|
||||
:<|> 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
|
||||
|
|
|
@ -87,41 +87,8 @@ 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
|
||||
txtLstToScopes :: [Text] -> Scopes
|
||||
txtLstToScopes scs =
|
||||
scs
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
|
@ -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)
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in a new issue