user detail management so far complete

This commit is contained in:
nek0 2019-10-14 17:40:20 +02:00
parent 83db59262d
commit c3cda9a253
3 changed files with 145 additions and 66 deletions

View file

@ -122,40 +122,6 @@ userOverviewControl mcookie uid mRefine = do
{ 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
@ -163,8 +129,11 @@ userManageControl mcookie = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $
(lookup "x-token" =<< fmap parseCookieText mcookie)
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie)
eUserDetails <- liftIO $ do
runClientM
(userGet (mkAuthenticatedRequest token authenticateReq))
@ -176,34 +145,65 @@ userManageControl mcookie = do
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"
}
err -> handleErrors
(fmap read mAuthUser)
[leftToMaybe (fst err), leftToMaybe (snd err)]
userManageDetailsSubmitControl mcookie _ =
error "not yet implemented"
userManageDetailsSubmitControl mcookie uds = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie)
eReturn <- liftIO $ runClientM
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
backend
case eReturn of
Right _ -> throwError $ redirect303 userManageLink
Left err -> handleErrors (fmap read mAuthUser) [Just err]
userManageAuthCreateControl mcookie _ =
error "not yet implemented"
userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie)
hashedPass <- hashPassword pass
eReturn <- liftIO $ runClientM
(authManageNewAuth
(mkAuthenticatedRequest token authenticateReq)
(MT.AuthSubmit (toEnum method) comment hashedPass)
)
backend
case eReturn of
Right _ -> throwError $ redirect303 userManageLink
Left err -> handleErrors (fmap read mAuthUser) [Just err]
userManageAuthDeleteControl mcookie _ =
error "not yet implemented"
userManageAuthDeleteControl mcookie (AuthDetailId adid) = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie)
eReturn <- liftIO $ runClientM
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
backend
case eReturn of
Right _ -> throwError $ redirect303 userManageLink
Left err -> case err of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 406
then
throwError $ redirect303 userManageLink
else
handleErrors (fmap read mAuthUser) [Just err]
_ -> handleErrors (fmap read mAuthUser) [Just err]

View file

@ -2,9 +2,11 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PackageImports #-}
module Util where
import Servant hiding (addHeader)
import Servant.Client
import Servant.Client.Core.Request
import Servant.Client.Core.Request (addHeader)
@ -22,6 +24,17 @@ import Web.Cookie
import Text.Printf (printf)
import Network.HTTP.Types.Status
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import Types
import API
setCookie
:: SetCookie
-> Request
@ -55,3 +68,63 @@ parseCookieText
parseCookieText = map
(\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two))
. T.splitOn "; "
handleErrors
:: (Traversable t, Show (t (Maybe ClientError)))
=> Maybe Int
-> t (Maybe ClientError)
-> UserHandler UserOverviewPage
handleErrors mAuthUser 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 mAuthUser Nothing
else
throwError $ err500
{ errBody = fromString (show merrs)
}
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"
)
]
}
)

View file

@ -201,7 +201,13 @@ userManagePage l10n locale userDetails authOverviews =
H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageAuthDeleteLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml $ comment
H.legend $ H.toHtml $ comment <> " - " <> case method of
MT.PrimaryPass ->
translate "Primary password"
MT.SecondaryPass ->
translate "Secondary password"
MT.ChallengeResponse ->
translate "Challenge response authentication"
H.div H.! HA.class_ "form-group required" $ do
H.input
H.! HA.class_ "form-control"
@ -253,10 +259,10 @@ userManagePage l10n locale userDetails authOverviews =
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.toHtml $ translate "Secondary password"
H.option H.!
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
H.toHtml $ translate "Primary Password"
H.toHtml $ translate "Primary password"
H.div H.! HA.class_ "form-group optional" $ do
H.button
H.! HA.class_ "btn btn-default"