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 =
|
type API auths =
|
||||||
Auth auths User :> Authenticated
|
Auth auths User :> Authenticated
|
||||||
:<|> LoginAPI
|
:<|> LoginAPI auths
|
||||||
|
|
||||||
type Authenticated =
|
type Authenticated =
|
||||||
HomepageAPI
|
HomepageAPI
|
||||||
|
|
|
@ -36,8 +36,9 @@ import Protolude
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Aggreact.Html
|
import Aggreact.Html
|
||||||
import Aggreact.Users (NewUser (..), User, UserHandler (..),
|
import Aggreact.Users (NewUser (..), User,
|
||||||
checkUserLogin, loginWidget)
|
UserHandler (..), checkUserLogin,
|
||||||
|
loginWidget)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
@ -45,9 +46,10 @@ import Database.Store
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.Auth.Server
|
import Servant.Auth.Server
|
||||||
import Servant.Errors
|
import Servant.Errors
|
||||||
import Servant.HTML.Blaze (HTML)
|
import Servant.HTML.Blaze (HTML)
|
||||||
import qualified Text.Blaze.Html5 as H
|
import qualified Text.Blaze.Html5 as H
|
||||||
import qualified Web.FormUrlEncoded as Form
|
import qualified Text.Blaze.Html5.Attributes as A
|
||||||
|
import qualified Web.FormUrlEncoded as Form
|
||||||
|
|
||||||
data Login = Login
|
data Login = Login
|
||||||
{ username :: Text
|
{ username :: Text
|
||||||
|
@ -59,20 +61,47 @@ instance FromJSON Login
|
||||||
instance Form.FromForm Login where
|
instance Form.FromForm Login where
|
||||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||||
|
|
||||||
type LoginAPI =
|
type LoginAPI auths =
|
||||||
"login"
|
("login" :> (ReqBody '[JSON, FormUrlEncoded] Login
|
||||||
:> (ReqBody '[JSON, FormUrlEncoded] Login
|
:> QueryParam "origin" Text
|
||||||
:> QueryParam "origin" Text
|
:> Post '[JSON, HTML]
|
||||||
:> Post '[JSON, HTML]
|
(Headers '[ Header "Set-Cookie" SetCookie
|
||||||
(Headers '[ Header "Set-Cookie" SetCookie
|
, Header "Set-Cookie" SetCookie]
|
||||||
, Header "Set-Cookie" SetCookie]
|
LoggedIn)
|
||||||
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 =
|
serverLoginAPI loginSettings =
|
||||||
checkCreds loginSettings
|
(checkCreds loginSettings
|
||||||
:<|> return LoginPage
|
:<|> 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 =
|
data LoginSettings =
|
||||||
LoginSettings
|
LoginSettings
|
||||||
|
|
|
@ -87,42 +87,9 @@ strToScope txt =
|
||||||
"" -> Just Write
|
"" -> Just Write
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
unloggedScopes :: AuthorizationStrategy -> Scopes
|
txtLstToScopes :: [Text] -> Scopes
|
||||||
unloggedScopes Anybody =
|
txtLstToScopes scs =
|
||||||
[ "comment:read"
|
scs
|
||||||
, "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
|
|
||||||
& traverse strToScope
|
& traverse strToScope
|
||||||
& fmap Set.fromList
|
& fmap Set.fromList
|
||||||
& fromMaybe Set.empty
|
& fromMaybe Set.empty
|
||||||
|
@ -130,9 +97,27 @@ scopesFor u LoggedInOnly =
|
||||||
scopeToStr :: Scope -> Text
|
scopeToStr :: Scope -> Text
|
||||||
scopeToStr (Scope res acc) = res <> case acc of Read -> ":read"; Write -> ":write"
|
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' :: AuthorizationStrategy -> Maybe User -> Scopes
|
||||||
userScopes' authStrat Nothing = unloggedScopes authStrat
|
userScopes' Anybody Nothing =
|
||||||
userScopes' authStrat (Just (Entity _ u _)) = scopesFor u authStrat
|
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' :: AuthorizationStrategy -> Scope -> Maybe User -> Bool
|
||||||
hasScope' authStrat s u = Set.member s (userScopes' authStrat u)
|
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.Markup
|
||||||
showScopes scopes = H.div $ do
|
showScopes scopes = H.div $ do
|
||||||
H.label "scopes"
|
H.label "scopes"
|
||||||
H.text (displayScopes scopes)
|
H.code (H.text (displayScopes scopes))
|
||||||
|
|
||||||
showUser :: User -> H.Markup
|
showUser :: User -> H.Markup
|
||||||
showUser user = do
|
showUser user = do
|
||||||
|
@ -136,7 +136,11 @@ deleteUserById (Just u) userHandler userId
|
||||||
|
|
||||||
loginWidget :: Maybe User -> H.Markup
|
loginWidget :: Maybe User -> H.Markup
|
||||||
loginWidget Nothing = H.a ! A.href "/login" $ H.text "Login"
|
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
|
-- List Users
|
||||||
data UsersPage =
|
data UsersPage =
|
||||||
|
|
Loading…
Reference in a new issue