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
, stm
, stm-containers
, vault
, either
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

View File

@ -35,6 +35,15 @@ type UserAPI =
:<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> 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"
:> QueryParam "destination" T.Text
:> Get '[HTML]
@ -52,6 +61,10 @@ type UserAPI =
userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
userManageLink :<|>
userManageDetailsSubmitLink :<|>
userManageAuthCreateLink :<|>
userManageAuthDeleteLink :<|>
authLink :<|>
authPostLink
) = allLinks (Proxy :: Proxy UserAPI)

View File

@ -147,14 +147,19 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
redirect303
(userOverviewLink
(read $ T.unpack user)
(Just MT.AvailableProducts)
Nothing
)
_ -> errHeaders $ redirect303 userSelectLink
throwError $ err303
{ errHeaders = headers ++
[ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
, ("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-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
, ( "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

View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Control.User where
import Servant
@ -14,8 +15,9 @@ import qualified Data.Text as T
import Data.Text.I18n
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.IO.Class (liftIO)
@ -80,38 +82,29 @@ userOverviewControl mcookie uid mRefine = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
let mMethod = T.unpack <$>
(lookup "x-method" =<< fmap parseCookieText mcookie)
euser <- liftIO $ do
let mToken = T.unpack $ fromMaybe "secret" $
lookup "x-token" =<< fmap parseCookieText mcookie
runClientM
(userGet (mkAuthenticatedRequest mToken authenticateReq) uid)
(userGet (mkAuthenticatedRequest mToken authenticateReq))
backend
eproducts <- liftIO $ runClientM
(productShortList mRefine)
backend
case (euser, eproducts) of
(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
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then do
liftIO $ print resp
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"
)
]
}
)
then
redirectOverAuth (Just uid) mRefine
else
throwError $ err500
{ errBody = fromString (show uerr)
@ -128,3 +121,89 @@ userOverviewControl mcookie uid mRefine = do
throwError $ err500
{ 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
:<|> userNewControl mcookie
:<|> userNewPostControl mcookie
:<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie
:<|> userManageAuthDeleteControl mcookie
:<|> authControl mcookie
:<|> authPostControl mcookie
)

View File

@ -20,3 +20,21 @@ data AuthReturn = AuthReturn
instance MimeRender HTML 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.Read (readEither)
import qualified Data.Text as T
import Servant.API
import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded
instance MimeUnrender HTML 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 UserManagePage = H.Html
type ProductListPage = 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.Attributes as HA
import qualified Data.Text as T
import Data.Text.I18n
import Data.String (fromString)
import Data.Maybe (isJust, fromJust)
import Data.Maybe (isJust, fromJust, fromMaybe)
-- imports from mateamt
@ -47,10 +49,11 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
userOverviewPage
:: L10n
-> Locale
-> MT.AuthMethod
-> MT.UserDetails
-> [MT.ProductShortOverview]
-> 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 "User Menu for ") <>
@ -63,16 +66,14 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
": " <>
(formatMoney $ MT.userDetailsBalance ud)
-- TODO: Add currency symbol
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
case method of
MT.PrimaryPass ->
userSettingsPointer
MT.SecondaryPass ->
productList
MT.ChallengeResponse -> do
userSettingsPointer
productList
where
translate = localize l10n locale . gettext
productBgStyle aid = HA.style $ mconcat
@ -84,6 +85,22 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
, " 1px 0 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
:: L10n
@ -132,3 +149,118 @@ userNewPage l10n locale = scaffold l10n locale (initPage $
$ H.toHtml $ translate "Submit"
where
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