start out user detail and auth detail management

This commit is contained in:
nek0 2019-10-14 15:07:17 +02:00
parent 41031c9c7a
commit 83db59262d
9 changed files with 297 additions and 37 deletions

View file

@ -68,7 +68,7 @@ executable matebeamter
, cryptonite , cryptonite
, stm , stm
, stm-containers , stm-containers
, vault , either
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -35,6 +35,15 @@ type UserAPI =
:<|> "user" :> "create" :> Get '[HTML] UserNewPage :<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "user" :> "manage" :> Get '[HTML] UserManagePage
:<|> "user" :> "manage" :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
:> Post '[HTML] UserManagePage
:<|> "user" :> "manage" :> "authcreate"
:> ReqBody '[FormUrlEncoded] AuthSubmitReturn
:> Post '[HTML] UserManagePage
:<|> "user" :> "manage" :> "authdelete"
:> ReqBody '[FormUrlEncoded] AuthDetailId
:> Post '[HTML] UserManagePage
:<|> "auth" :<|> "auth"
:> QueryParam "destination" T.Text :> QueryParam "destination" T.Text
:> Get '[HTML] :> Get '[HTML]
@ -52,6 +61,10 @@ type UserAPI =
userOverviewLink :<|> userOverviewLink :<|>
userNewLink :<|> userNewLink :<|>
userNewPostLink :<|> userNewPostLink :<|>
userManageLink :<|>
userManageDetailsSubmitLink :<|>
userManageAuthCreateLink :<|>
userManageAuthDeleteLink :<|>
authLink :<|> authLink :<|>
authPostLink authPostLink
) = allLinks (Proxy :: Proxy UserAPI) ) = allLinks (Proxy :: Proxy UserAPI)

View file

@ -147,14 +147,19 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
redirect303 redirect303
(userOverviewLink (userOverviewLink
(read $ T.unpack user) (read $ T.unpack user)
(Just MT.AvailableProducts) Nothing
) )
_ -> errHeaders $ redirect303 userSelectLink _ -> errHeaders $ redirect303 userSelectLink
throwError $ err303 throwError $ err303
{ errHeaders = headers ++ { errHeaders = headers ++
[ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT") [ ( "Set-Cookie"
, ("Set-Cookie", "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT") , "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
, ("Set-Cookie", "x-token=" <> fromString (T.unpack token) <>";Path=/") , ( "Set-Cookie"
, "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
, ( "Set-Cookie"
, "x-token=" <> fromString (T.unpack token) <>";Path=/")
, ( "Set-Cookie"
, "x-method=" <> fromString (show $ fromEnum method) <>";Path=/")
] ]
} }
Right MT.Denied -> throwError $ err401 Right MT.Denied -> throwError $ err401

View file

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Control.User where module Control.User where
import Servant import Servant
@ -14,8 +15,9 @@ import qualified Data.Text as T
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Either.Combinators (leftToMaybe)
import Control.Monad (void) import Control.Monad (void, when)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -80,38 +82,29 @@ userOverviewControl mcookie uid mRefine = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
let mMethod = T.unpack <$>
(lookup "x-method" =<< fmap parseCookieText mcookie)
euser <- liftIO $ do euser <- liftIO $ do
let mToken = T.unpack $ fromMaybe "secret" $ let mToken = T.unpack $ fromMaybe "secret" $
lookup "x-token" =<< fmap parseCookieText mcookie lookup "x-token" =<< fmap parseCookieText mcookie
runClientM runClientM
(userGet (mkAuthenticatedRequest mToken authenticateReq) uid) (userGet (mkAuthenticatedRequest mToken authenticateReq))
backend backend
eproducts <- liftIO $ runClientM eproducts <- liftIO $ runClientM
(productShortList mRefine) (productShortList mRefine)
backend backend
case (euser, eproducts) of case (euser, eproducts) of
(Right ud, Right prods) -> (Right ud, Right prods) ->
return $ userOverviewPage l10n loc ud prods case mMethod of
Just method ->
return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
Nothing ->
redirectOverAuth (Just uid) mRefine
(Left uerr, Right _) -> case uerr of (Left uerr, Right _) -> case uerr of
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401 if statusCode (responseStatusCode resp) == 401
then do then
liftIO $ print resp redirectOverAuth (Just uid) mRefine
let redirectHeaders = errHeaders $
redirect303 (authLink (Just $ "/" <>
fromString (show $ linkURI (userOverviewLink uid mRefine))))
throwError
(err303
{ errHeaders = redirectHeaders ++
[ ( "Set-Cookie"
, "x-auth-user=" <> (fromString $ show uid) <> "; Path=/"
)
, ( "Set-Cookie"
, "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
)
]
}
)
else else
throwError $ err500 throwError $ err500
{ errBody = fromString (show uerr) { errBody = fromString (show uerr)
@ -128,3 +121,89 @@ userOverviewControl mcookie uid mRefine = do
throwError $ err500 throwError $ err500
{ errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr) { errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr)
} }
redirectOverAuth
:: Maybe Int
-> Maybe (MT.ProductRefine)
-> UserHandler UserOverviewPage
redirectOverAuth muid mRefine = do
let redirectHeaders = errHeaders $
redirect303 (authLink (Just $ "/" <>
fromString (show $ linkURI (case muid of
Just uid -> userOverviewLink uid mRefine
Nothing -> userSelectLink
))))
throwError
(err303
{ errHeaders = redirectHeaders ++ (case muid of
Just uid ->
[ ( "Set-Cookie"
, "x-auth-user=" <> (fromString $ show uid) <> "; Path=/"
)
]
Nothing ->
[
]
)
++
[ ( "Set-Cookie"
, "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
)
, ( "Set-Cookie"
, "x-method=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
)
]
}
)
userManageControl
:: Maybe T.Text
-> UserHandler UserManagePage
userManageControl mcookie = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
token = T.unpack $ fromMaybe "secret" $
(lookup "x-token" =<< fmap parseCookieText mcookie)
eUserDetails <- liftIO $ do
runClientM
(userGet (mkAuthenticatedRequest token authenticateReq))
backend
eAuthOverviews <- liftIO $ do
runClientM
(authManageList (mkAuthenticatedRequest token authenticateReq))
backend
case (eUserDetails, eAuthOverviews) of
(Right userDetails, Right authOverviews) ->
return $ userManagePage l10n loc userDetails authOverviews
err -> handleErrors [leftToMaybe (fst err), leftToMaybe (snd err)]
where
handleErrors merrs = do
codes <- mapM
(\eerr -> case eerr of
Just (FailureResponse _ resp) ->
return $ statusCode (responseStatusCode resp)
Just err ->
throwError $ err500
{ errBody = fromString (show err)
}
Nothing ->
return 200
)
merrs
if (any (== 401) codes)
then
redirectOverAuth Nothing Nothing
else
throwError $ err500
{ errBody = "Could not handle errors in handleErrors"
}
userManageDetailsSubmitControl mcookie _ =
error "not yet implemented"
userManageAuthCreateControl mcookie _ =
error "not yet implemented"
userManageAuthDeleteControl mcookie _ =
error "not yet implemented"

View file

@ -47,6 +47,10 @@ userApp initState = serveWithContext userApi (EmptyContext) $
:<|> userOverviewControl mcookie :<|> userOverviewControl mcookie
:<|> userNewControl mcookie :<|> userNewControl mcookie
:<|> userNewPostControl mcookie :<|> userNewPostControl mcookie
:<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie
:<|> userManageAuthDeleteControl mcookie
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
) )

View file

@ -20,3 +20,21 @@ data AuthReturn = AuthReturn
instance MimeRender HTML AuthReturn instance MimeRender HTML AuthReturn
instance FromForm AuthReturn instance FromForm AuthReturn
data AuthSubmitReturn = AuthSubmitReturn
{ authSubmitReturnComment :: T.Text
, authSubmitReturnPass :: T.Text
, authSubmitReturnMethod :: Int
}
deriving (Show, Generic)
instance MimeRender HTML AuthSubmitReturn
instance FromForm AuthSubmitReturn
newtype AuthDetailId = AuthDetailId
{ unId :: Int
}
deriving (Show, Generic)
instance MimeRender HTML AuthDetailId
instance FromForm AuthDetailId

View file

@ -9,9 +9,16 @@ import GHC.Generics
import Text.Blaze import Text.Blaze
import Text.Read (readEither)
import qualified Data.Text as T
import Servant.API import Servant.API
import Servant.HTML.Blaze import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded import Web.Internal.FormUrlEncoded
instance MimeUnrender HTML MT.UserSubmit instance MimeUnrender HTML MT.UserSubmit
instance FromForm MT.UserSubmit instance FromForm MT.UserSubmit
instance MimeUnrender HTML MT.UserDetailsSubmit
instance FromForm MT.UserDetailsSubmit

View file

@ -8,6 +8,8 @@ type UserNewPage = H.Html
type UserOverviewPage = H.Html type UserOverviewPage = H.Html
type UserManagePage = H.Html
type ProductListPage = H.Html type ProductListPage = H.Html
type AuthPage = H.Html type AuthPage = H.Html

View file

@ -7,11 +7,13 @@ import Servant.Links
import qualified Text.Blaze.Html5 as H hiding (style) import qualified Text.Blaze.Html5 as H hiding (style)
import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Html5.Attributes as HA
import qualified Data.Text as T
import Data.Text.I18n import Data.Text.I18n
import Data.String (fromString) import Data.String (fromString)
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust, fromMaybe)
-- imports from mateamt -- imports from mateamt
@ -47,10 +49,11 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
userOverviewPage userOverviewPage
:: L10n :: L10n
-> Locale -> Locale
-> MT.AuthMethod
-> MT.UserDetails -> MT.UserDetails
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> UserOverviewPage -> UserOverviewPage
userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
(localize l10n locale $ gettext "Matebeamter") <> (localize l10n locale $ gettext "Matebeamter") <>
" - " <> " - " <>
(localize l10n locale $ gettext "User Menu for ") <> (localize l10n locale $ gettext "User Menu for ") <>
@ -63,16 +66,14 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
": " <> ": " <>
(formatMoney $ MT.userDetailsBalance ud) (formatMoney $ MT.userDetailsBalance ud)
-- TODO: Add currency symbol -- TODO: Add currency symbol
H.ul H.! HA.class_ "product_list" $ case method of
mapM_ MT.PrimaryPass ->
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do userSettingsPointer
H.li H.! HA.class_ "product" H.!? MT.SecondaryPass ->
(isJust avatarid productList
, productBgStyle (fromString $ show $ fromJust avatarid) MT.ChallengeResponse -> do
) $ userSettingsPointer
H.a H.! HA.href ("#" <> fromString (show pid)) $ H.toHtml ident productList
)
pos
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
productBgStyle aid = HA.style $ mconcat productBgStyle aid = HA.style $ mconcat
@ -84,6 +85,22 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
, " 1px 0 1px black," , " 1px 0 1px black,"
, " 0 -1px 1px black;" , " 0 -1px 1px black;"
] ]
userSettingsPointer =
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink)) $
H.toHtml $ translate "Manage user settings"
productList =
H.p $
H.ul H.! HA.class_ "product_list" $
mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
H.li H.! HA.class_ "product" H.!?
(isJust avatarid
, productBgStyle (fromString $ show $ fromJust avatarid)
) $
H.a H.! HA.href ("#" <> fromString (show pid)) $
H.toHtml ident
)
pos
userNewPage userNewPage
:: L10n :: L10n
@ -132,3 +149,118 @@ userNewPage l10n locale = scaffold l10n locale (initPage $
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
userManagePage
:: L10n
-> Locale
-> MT.UserDetails
-> [MT.AuthOverview]
-> UserManagePage
userManagePage l10n locale userDetails authOverviews =
scaffold l10n locale (initPage $
(translate "Matebeamter") <>
" - " <>
(translate "Manage user data")
) $ do
H.p $ H.form
H.! HA.method "post"
H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageDetailsSubmitLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml $ translate "User details"
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
H.input
H.! HA.id "username"
H.! HA.class_ "form-control"
H.! HA.name "userDetailsSubmitIdent"
H.! HA.type_ "text"
H.! HA.required ""
H.! HA.value
(fromString $ T.unpack $ MT.userDetailsIdent userDetails)
H.div H.! HA.class_ "form-group optional" $ do
H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
H.input
H.! HA.id "useremail"
H.! HA.class_ "form-control"
H.! HA.name "userDetailsSubmitEmail"
H.! HA.type_ "email"
H.! HA.required ""
H.! HA.value
(fromMaybe "" $ fromString <$> T.unpack <$>
MT.userDetailsEmail userDetails)
H.div H.! HA.class_ "form-group optional" $ do
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
H.p $ do
mapM_
(\(MT.AuthOverview aoid comment method) -> H.form
H.! HA.method "post"
H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageAuthDeleteLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml $ comment
H.div H.! HA.class_ "form-group required" $ do
H.input
H.! HA.class_ "form-control"
H.! HA.name "unId"
H.! HA.type_ "hidden"
H.! HA.required ""
H.! HA.value (fromString $ show aoid)
H.div H.! HA.class_ "form-group optional" $ do
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Delete"
)
authOverviews
H.form
H.! HA.method "post"
H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageAuthCreateLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml $ translate "Authentication details"
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "comment" $ H.toHtml $
translate "Comment"
H.input
H.! HA.id "comment"
H.! HA.class_ "form_control"
H.! HA.name "authSubmitReturnComment"
H.! HA.type_ "text"
H.! HA.required ""
H.! HA.value ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "password" $ H.toHtml $
translate "Password"
H.input
H.! HA.id "password"
H.! HA.class_ "form_control"
H.! HA.name "authSubmitReturnPass"
H.! HA.type_ "password"
H.! HA.required ""
H.! HA.value ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "method" $ H.toHtml $
translate "Authentication Method"
H.select
H.! HA.id "method"
H.! HA.class_ "form-control"
H.! HA.name "authSubmitReturnMethod"
H.! HA.required ""
H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do
H.option H.!
HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $
H.toHtml $ translate "Secondary Password"
H.option H.!
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
H.toHtml $ translate "Primary Password"
H.div H.! HA.class_ "form-group optional" $ do
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where
translate = localize l10n locale . gettext