user detail management so far complete
This commit is contained in:
parent
83db59262d
commit
c3cda9a253
3 changed files with 145 additions and 66 deletions
|
|
@ -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
|
||||
err -> handleErrors
|
||||
(fmap read mAuthUser)
|
||||
[leftToMaybe (fst err), leftToMaybe (snd err)]
|
||||
|
||||
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 (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)
|
||||
)
|
||||
merrs
|
||||
if (any (== 401) codes)
|
||||
backend
|
||||
case eReturn of
|
||||
Right _ -> throwError $ redirect303 userManageLink
|
||||
Left err -> handleErrors (fmap read mAuthUser) [Just err]
|
||||
|
||||
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
|
||||
redirectOverAuth Nothing Nothing
|
||||
throwError $ redirect303 userManageLink
|
||||
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"
|
||||
handleErrors (fmap read mAuthUser) [Just err]
|
||||
_ -> handleErrors (fmap read mAuthUser) [Just err]
|
||||
|
|
|
|||
73
src/Util.hs
73
src/Util.hs
|
|
@ -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"
|
||||
)
|
||||
]
|
||||
}
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue