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

View file

@ -4,4 +4,3 @@ module Control
import Control.Auth as C import Control.Auth as C
import Control.User 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.Maybe (fromMaybe)
import Data.Either (isRight, rights, lefts) import Data.Either (isRight, rights, lefts)
import Control.Monad (foldM)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -36,17 +35,32 @@ import Hash
authControl authControl
:: Maybe T.Text :: Maybe T.Text
-> Maybe T.Text
-> UserHandler -> UserHandler
(Headers (Headers
'[ Header "Set-Cookie" T.Text '[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text
] ]
AuthPage) AuthPage)
authControl mcookie@(Just cookie) = do authControl mcookie@(Just cookie) mDestination = do
let mauthUser = lookup "x-auth-user" (parseCookieText cookie) let mAuthUser = lookup "x-auth-user" (parseCookieText cookie)
case mauthUser of let mToken = lookup "x-token" (parseCookieText cookie)
Just authUser -> do 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 (ReadState _ backend _) <- ask
let trs = map let trs = map
(MT.TicketRequest (MT.TicketRequest
@ -70,7 +84,7 @@ authControl mcookie@(Just cookie) = do
else throwError $ err400 else throwError $ err400
{ errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos { errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos
} }
Nothing -> (Nothing, _) ->
error $ "Error handling not yet implemented properly, but here's your user: " error $ "Error handling not yet implemented properly, but here's your user: "
<> (fromString $ T.unpack $ fromMaybe "" $ <> (fromString $ T.unpack $ fromMaybe "" $
lookup "x-auth-user" (parseCookieText cookie) lookup "x-auth-user" (parseCookieText cookie)
@ -81,7 +95,6 @@ authControl mcookie@(Just cookie) = do
-> UserHandler -> UserHandler
(Headers (Headers
'[ Header "Set-Cookie" T.Text '[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text
] ]
AuthPage) AuthPage)
@ -94,21 +107,21 @@ authControl mcookie@(Just cookie) = do
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <> "x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
(fromString $ T.unpack ticket) <> ";Path=/") (fromString $ T.unpack ticket) <> ";Path=/")
tupAuthInfos tupAuthInfos
return $ addHeader return $
"x-auth-user=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" $ addHeader (ticketHeaders !! 0) $
addHeader (ticketHeaders !! 0) $ addHeader (ticketHeaders !! 1) $
addHeader (ticketHeaders !! 1) $ authPage l10n loc mDestination
authPage l10n loc authControl Nothing _ =
authControl Nothing =
throwError $ err400 throwError $ err400
{ errBody = "No cookie present." { errBody = "No cookie present."
} }
authPostControl authPostControl
:: Maybe T.Text :: Maybe T.Text
-> Maybe T.Text
-> AuthReturn -> AuthReturn
-> UserHandler UserSelectPage -> 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)) $ let mticket = lookup ("x-ticket-" <> fromString (show method)) $
parseCookieText cookies parseCookieText cookies
case mticket of case mticket of
@ -125,10 +138,18 @@ authPostControl (Just cookies) (AuthReturn pass method) = do
backend backend
case etoken of case etoken of
Right (MT.Granted (MT.AuthToken token)) -> do Right (MT.Granted (MT.AuthToken token)) -> do
let headers = errHeaders $ let mUser = lookup "x-auth-user" $ parseCookieText cookies
redirect303 headers = case (mDestination, mUser) of
-- FIXME: redirect to product select (Just destination, _) ->
(productListLink (Just MT.AvailableProducts)) [ ("Location", fromString (T.unpack destination))
]
(Nothing, Just user) -> errHeaders $
redirect303
(userOverviewLink
(read $ T.unpack user)
(Just MT.AvailableProducts)
)
_ -> 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", "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 Nothing -> throwError $ err400
{ errBody = "No ticket cookie present." { errBody = "No ticket cookie present."
} }
authPostControl Nothing _ = throwError $ err400 authPostControl Nothing _ _ = throwError $ err400
{ errBody = "No ticket cookie present." { 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 userOverviewControl
:: Maybe T.Text :: Maybe T.Text
-> Int -> Int
-> Maybe MT.ProductRefine
-> UserHandler UserOverviewPage -> UserHandler UserOverviewPage
userOverviewControl mcookie uid = do 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)
euser <- liftIO $ runClientM euser <- liftIO $ do
(userGet (mkAuthenticatedRequest "secret" authenticateReq) uid) let mToken = T.unpack $ fromMaybe "secret" $
backend lookup "x-token" =<< fmap parseCookieText mcookie
runClientM
(userGet (mkAuthenticatedRequest mToken authenticateReq) uid)
backend
eproducts <- liftIO $ runClientM eproducts <- liftIO $ runClientM
(productShortList Nothing) (productShortList mRefine)
backend backend
case (euser, eproducts) of case (euser, eproducts) of
(Right ud, Right prods) -> (Right ud, Right prods) ->
@ -92,12 +96,18 @@ userOverviewControl mcookie uid = do
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401 if statusCode (responseStatusCode resp) == 401
then do then do
let redirectHeaders = errHeaders $ redirect303 authLink liftIO $ print resp
let redirectHeaders = errHeaders $
redirect303 (authLink (Just $ "/" <>
fromString (show $ linkURI (userOverviewLink uid mRefine))))
throwError throwError
(err303 (err303
{ errHeaders = redirectHeaders ++ { errHeaders = redirectHeaders ++
[ ("Set-Cookie", "x-auth-user=" <> (fromString $ show uid) [ ( "Set-Cookie"
<> "; Path=/" , "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 :<|> userOverviewControl mcookie
:<|> userNewControl mcookie :<|> userNewControl mcookie
:<|> userNewPostControl mcookie :<|> userNewPostControl mcookie
:<|> productListControl mcookie
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
) )

View file

@ -37,7 +37,7 @@ formatMoney amount = pre <> t <> "," <> c
t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp) t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = fromString $ snd sp c = fromString $ snd sp
sp = tail <$> sp = tail <$>
break (== '.') (printf "%.2f" (abs amount)) break (== '.') (printf "%.2f" (fromIntegral $ abs amount :: Float))
redirect303 redirect303
:: Link :: Link
@ -45,7 +45,7 @@ redirect303
redirect303 link = redirect303 link =
err303 err303
{ errHeaders = { 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.Auth as V
import View.User 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 as H
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 import Data.String
@ -24,8 +26,9 @@ import View.Scaffold
authPage authPage
:: L10n :: L10n
-> Locale -> Locale
-> Maybe T.Text
-> AuthPage -> AuthPage
authPage l10n locale = scaffold authPage l10n locale mDestination = scaffold
l10n l10n
locale locale
(initPage $ (initPage $
@ -36,7 +39,8 @@ authPage l10n locale = scaffold
$ do $ do
H.p $ H.form H.p $ H.form
H.! HA.method "post" 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.! HA.enctype "application/x-www-form-urlencoded" $ do
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "method" $ H.toHtml $ 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") (translate "Home")
) $ do ) $ do
mapM_ (\(MT.UserSummary uid ident _) -> do mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userOverviewLink uid)) $ H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $
H.toHtml ident userOverviewLink uid Nothing)) $
H.toHtml ident
) uss ) uss
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $ H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $
H.toHtml $ translate "New user" H.toHtml $ translate "New user"