delete duplicate product page attempts, refine authenitcation

This commit is contained in:
nek0 2019-10-14 06:38:16 +02:00
parent cb8e927eae
commit 41031c9c7a
11 changed files with 74 additions and 137 deletions

View File

@ -30,22 +30,21 @@ import Types
type UserAPI =
Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] UserOverviewPage
:<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> Post '[HTML] UserSelectPage
:<|> "product" :> "list" :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] ProductListPage
:<|> "auth"
:> QueryParam "destination" T.Text
:> Get '[HTML]
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
:<|> "auth" :> ReqBody '[FormUrlEncoded] AuthReturn
:<|> "auth" :> QueryParam "destination" T.Text
:> ReqBody '[FormUrlEncoded] AuthReturn
:> Post '[HTML] UserSelectPage
)
@ -53,7 +52,6 @@ type UserAPI =
userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
productListLink :<|>
authLink :<|>
authPostLink
) = allLinks (Proxy :: Proxy UserAPI)

View File

@ -4,4 +4,3 @@ module Control
import Control.Auth as C
import Control.User as C
import Control.Product as C

View File

@ -17,7 +17,6 @@ import Data.String (fromString)
import Data.Maybe (fromMaybe)
import Data.Either (isRight, rights, lefts)
import Control.Monad (foldM)
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
@ -36,17 +35,32 @@ import Hash
authControl
:: Maybe T.Text
-> Maybe T.Text
-> UserHandler
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
authControl mcookie@(Just cookie) = do
let mauthUser = lookup "x-auth-user" (parseCookieText cookie)
case mauthUser of
Just authUser -> do
authControl mcookie@(Just cookie) mDestination = do
let mAuthUser = lookup "x-auth-user" (parseCookieText cookie)
let mToken = lookup "x-token" (parseCookieText cookie)
case (mAuthUser, mToken) of
(Just authUser, Just _) -> do
throwError $ case mDestination of
Just destination ->
err303
{ errHeaders =
[ ("Location", fromString (T.unpack destination))
]
}
Nothing ->
redirect303
(userOverviewLink
(read $ T.unpack authUser)
Nothing
)
(Just authUser, Nothing) -> do
(ReadState _ backend _) <- ask
let trs = map
(MT.TicketRequest
@ -70,7 +84,7 @@ authControl mcookie@(Just cookie) = do
else throwError $ err400
{ errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos
}
Nothing ->
(Nothing, _) ->
error $ "Error handling not yet implemented properly, but here's your user: "
<> (fromString $ T.unpack $ fromMaybe "" $
lookup "x-auth-user" (parseCookieText cookie)
@ -81,7 +95,6 @@ authControl mcookie@(Just cookie) = do
-> UserHandler
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
@ -94,21 +107,21 @@ authControl mcookie@(Just cookie) = do
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
(fromString $ T.unpack ticket) <> ";Path=/")
tupAuthInfos
return $ addHeader
"x-auth-user=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" $
addHeader (ticketHeaders !! 0) $
addHeader (ticketHeaders !! 1) $
authPage l10n loc
authControl Nothing =
return $
addHeader (ticketHeaders !! 0) $
addHeader (ticketHeaders !! 1) $
authPage l10n loc mDestination
authControl Nothing _ =
throwError $ err400
{ errBody = "No cookie present."
}
authPostControl
:: Maybe T.Text
-> Maybe T.Text
-> AuthReturn
-> UserHandler UserSelectPage
authPostControl (Just cookies) (AuthReturn pass method) = do
authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
let mticket = lookup ("x-ticket-" <> fromString (show method)) $
parseCookieText cookies
case mticket of
@ -125,10 +138,18 @@ authPostControl (Just cookies) (AuthReturn pass method) = do
backend
case etoken of
Right (MT.Granted (MT.AuthToken token)) -> do
let headers = errHeaders $
redirect303
-- FIXME: redirect to product select
(productListLink (Just MT.AvailableProducts))
let mUser = lookup "x-auth-user" $ parseCookieText cookies
headers = case (mDestination, mUser) of
(Just destination, _) ->
[ ("Location", fromString (T.unpack destination))
]
(Nothing, Just user) -> errHeaders $
redirect303
(userOverviewLink
(read $ T.unpack user)
(Just MT.AvailableProducts)
)
_ -> errHeaders $ redirect303 userSelectLink
throwError $ err303
{ errHeaders = headers ++
[ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
@ -145,6 +166,6 @@ authPostControl (Just cookies) (AuthReturn pass method) = do
Nothing -> throwError $ err400
{ errBody = "No ticket cookie present."
}
authPostControl Nothing _ = throwError $ err400
authPostControl Nothing _ _ = throwError $ err400
{ errBody = "No ticket cookie present."
}

View File

@ -1,49 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-}
module Control.Product where
import Servant
import Servant.Client
import Servant.Server
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Data.Text.I18n
import Data.String (fromString)
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import View
import Types
import Client
import Util
productListControl
:: Maybe T.Text
-> Maybe MT.ProductRefine
-> UserHandler ProductListPage
productListControl mcookie mrefine = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
eProducts <- liftIO $ runClientM
(productShortList mrefine)
backend
case eProducts of
Right products ->
return $ productListPage l10n loc mrefine products
Left err ->
throwError $ err500
{ errBody = fromString $ show err
}

View File

@ -74,16 +74,20 @@ userNewPostControl _ us@(MT.UserSubmit ident email pass) = do
userOverviewControl
:: Maybe T.Text
-> Int
-> Maybe MT.ProductRefine
-> UserHandler UserOverviewPage
userOverviewControl mcookie uid = do
userOverviewControl mcookie uid mRefine = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
euser <- liftIO $ runClientM
(userGet (mkAuthenticatedRequest "secret" authenticateReq) uid)
backend
euser <- liftIO $ do
let mToken = T.unpack $ fromMaybe "secret" $
lookup "x-token" =<< fmap parseCookieText mcookie
runClientM
(userGet (mkAuthenticatedRequest mToken authenticateReq) uid)
backend
eproducts <- liftIO $ runClientM
(productShortList Nothing)
(productShortList mRefine)
backend
case (euser, eproducts) of
(Right ud, Right prods) ->
@ -92,12 +96,18 @@ userOverviewControl mcookie uid = do
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then do
let redirectHeaders = errHeaders $ redirect303 authLink
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-auth-user=" <> (fromString $ show uid) <> "; Path=/"
)
, ( "Set-Cookie"
, "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
)
]
}

View File

@ -47,7 +47,6 @@ userApp initState = serveWithContext userApi (EmptyContext) $
:<|> userOverviewControl mcookie
:<|> userNewControl mcookie
:<|> userNewPostControl mcookie
:<|> productListControl mcookie
:<|> authControl mcookie
:<|> authPostControl mcookie
)

View File

@ -37,7 +37,7 @@ formatMoney amount = pre <> t <> "," <> c
t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = fromString $ snd sp
sp = tail <$>
break (== '.') (printf "%.2f" (abs amount))
break (== '.') (printf "%.2f" (fromIntegral $ abs amount :: Float))
redirect303
:: Link
@ -45,7 +45,7 @@ redirect303
redirect303 link =
err303
{ errHeaders =
[ ("Location", "/" <> (fromString $ show $ linkURI $ link))
[ ("Location", "/" <> (fromString $ show $ linkURI link))
]
}

View File

@ -4,4 +4,3 @@ module View
import View.Auth as V
import View.User as V
import View.Product as V

View File

@ -7,6 +7,8 @@ import Servant.Links (linkURI)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Data.Text as T
import Data.Text.I18n
import Data.String
@ -24,8 +26,9 @@ import View.Scaffold
authPage
:: L10n
-> Locale
-> Maybe T.Text
-> AuthPage
authPage l10n locale = scaffold
authPage l10n locale mDestination = scaffold
l10n
locale
(initPage $
@ -36,7 +39,8 @@ authPage l10n locale = scaffold
$ do
H.p $ H.form
H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ authPostLink))
H.! HA.action ("/" <> (fromString $ show $ linkURI $
authPostLink mDestination))
H.! HA.enctype "application/x-www-form-urlencoded" $ do
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "method" $ H.toHtml $

View File

@ -1,45 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module View.Product where
import Servant.Links
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Data.Text.I18n
import Data.String (fromString)
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import Util
import Types
import View.Scaffold
import API
productListPage
:: L10n
-> Locale
-> Maybe MT.ProductRefine
-> [MT.ProductShortOverview]
-> ProductListPage
productListPage l10n locale mRefine psos = scaffold l10n locale (initPage $
(translate "Matebeamter") <>
" - " <>
(translate "Product list")
) $ if null psos
then
H.h1 $ H.toHtml $ translate "No products present"
else do
mapM_ (\(MT.ProductShortOverview pid ident price amount ml mAvatar) -> do
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $
productListLink mRefine)) $
H.toHtml ident
) psos
where
translate = localize l10n locale . gettext

View File

@ -35,8 +35,9 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
(translate "Home")
) $ do
mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userOverviewLink uid)) $
H.toHtml ident
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $
userOverviewLink uid Nothing)) $
H.toHtml ident
) uss
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $
H.toHtml $ translate "New user"