one trainride later

This commit is contained in:
nek0 2019-10-24 18:05:22 +02:00
parent f41aab662a
commit 96304fe665
9 changed files with 247 additions and 169 deletions

View file

@ -32,9 +32,11 @@ type UserAPI =
:> Get '[HTML] UserOverviewPage :> Get '[HTML] UserOverviewPage
:<|> "user" :> Capture "id" Int :> "buy" :<|> "user" :> Capture "id" Int :> "buy"
:> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
:> QueryParam "force" Bool
:> Post '[HTML] BuyConfirmPage :> Post '[HTML] BuyConfirmPage
:<|> "user" :> Capture "id" Int :> "purchasecomplete" :<|> "user" :> Capture "id" Int :> "purchasecomplete"
:> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
:> QueryParam "force" Bool
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage :<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage
:<|> "user" :> Capture "id" Int :> "manage" :<|> "user" :> Capture "id" Int :> "manage"

View file

@ -110,7 +110,7 @@ authControl mcookie mDestination = do
return $ return $
addHeader (head ticketHeaders) $ addHeader (head ticketHeaders) $
addHeader (ticketHeaders !! 1) $ addHeader (ticketHeaders !! 1) $
authPage l10n loc mDestination authPage l10n loc mDestination mcookie
authPostControl authPostControl
:: Maybe T.Text :: Maybe T.Text

View file

@ -40,8 +40,9 @@ buyControl
:: Maybe T.Text :: Maybe T.Text
-> Int -> Int
-> [MT.PurchaseDetail] -> [MT.PurchaseDetail]
-> Maybe Bool
-> UserHandler BuyConfirmPage -> UserHandler BuyConfirmPage
buyControl mcookie uid pds = buyControl mcookie uid pds forceBuy =
if not (null pds) if not (null pds)
then do then do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
@ -69,7 +70,7 @@ buyControl mcookie uid pds =
) )
0 0
ziptup ziptup
return (buyConfirmPage l10n loc uid ziptup total) return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie)
else else
throwError (redirect303 $ userOverviewLink uid Nothing) throwError (redirect303 $ userOverviewLink uid Nothing)
@ -77,8 +78,12 @@ purchaseControl
:: Maybe T.Text :: Maybe T.Text
-> Int -> Int
-> [MT.PurchaseDetail] -> [MT.PurchaseDetail]
-> Maybe Bool
-> UserHandler UserSelectPage -> UserHandler UserSelectPage
purchaseControl mcookie uid pds = purchaseControl mcookie uid pds forceBuy = do
l10n <- asks rsL10n
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
if not (null pds) if not (null pds)
then do then do
backend <- asks rsBackend backend <- asks rsBackend
@ -92,46 +97,48 @@ purchaseControl mcookie uid pds =
case eresult of case eresult of
Right result -> case result of Right result -> case result of
(MT.PurchaseResult MT.PurchaseOK []) -> (MT.PurchaseResult MT.PurchaseOK []) ->
logoutAndRedirectHome backend token logoutAndRedirectHome
(translate l10n loc "Purchase successful")
backend
token
(MT.PurchaseResult MT.PurchaseDebtful []) -> (MT.PurchaseResult MT.PurchaseDebtful []) ->
logoutAndRedirectHome backend token logoutAndRedirectHome
(translate l10n loc "Purchase successful")
backend
token
(MT.PurchaseResult (MT.PayAmount price) []) -> (MT.PurchaseResult (MT.PayAmount price) []) ->
throwError $ err500 logoutAndRedirectHome
{ errBody = (translate l10n loc "Please Pay" <> ": " <> formatMoney price)
"No messaging system implemented. " backend
<> "Purchase was processed, though. " token
<> "Please pay " <> (fromString $ T.unpack $ formatMoney price)
<> " in cash."
}
(MT.PurchaseResult (MT.PayAmount price) miss) -> (MT.PurchaseResult (MT.PayAmount price) miss) ->
throwError $ err500 throwError
{ errBody = $ addMessage (translate l10n loc "Please Pay" <> ": "
"No messaging system implemented. " <> formatMoney price
<> "Purchase was processed, though. " <> "\n"
<> "Please pay " <> (fromString $ T.unpack $ formatMoney price) <> translate l10n loc ("But there seems to be something missing.")
<> " in cash. " )
<> "Stock is lacking following items: " $ redirect307 (buyLink uid (Just True))
<> fromString (show miss)
}
(MT.PurchaseResult _ miss) -> (MT.PurchaseResult _ miss) ->
throwError $ err500 throwError
{ errBody = $ addMessage (translate l10n loc "Purchase partly successful.")
"No messaging system implemented. " $ redirect307 (buyLink uid (Just True))
<> "Purchase was processed, though. "
<> "Stock is lacking following items: "
<> fromString (show miss)
}
Left err -> Left err ->
throwError $ err500 throwError $ err500
{ errBody = fromString (show err) { errBody = fromString (show err)
} }
else else
throwError (redirect303 $ userOverviewLink uid Nothing) throwError
$ addMessage (translate l10n loc "Please choose your product(s)")
$ (redirect303 $ userOverviewLink uid Nothing)
where where
logoutAndRedirectHome backend token = do logoutAndRedirectHome message backend token = do
void $ liftIO $ runClientM void $ liftIO $ runClientM
(authLogout (authLogout
(mkAuthenticatedRequest token authenticateReq) (mkAuthenticatedRequest token authenticateReq)
) )
backend backend
throwError $ redirect303 userSelectLink throwError
$ addMessage message
$ redirect303 userSelectLink
translate l10n locale = localize l10n locale . gettext

View file

@ -46,7 +46,7 @@ userSelectControl mcookie = do
backend backend
case euser of case euser of
Right uss -> Right uss ->
return $ userSelectPage l10n loc uss return $ userSelectPage l10n loc uss mcookie
Left err -> Left err ->
error $ show err error $ show err
@ -55,7 +55,7 @@ userNewControl mcookie = do
(ReadState l10n _ _) <- ask (ReadState l10n _ _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
return $ userNewPage l10n loc return $ userNewPage l10n loc mcookie
userNewPostControl userNewPostControl
:: Maybe T.Text :: Maybe T.Text
@ -102,7 +102,8 @@ userOverviewControl mcookie uid mRefine = do
Just method -> Just method ->
if fmap read mAuthUser == Just uid if fmap read mAuthUser == Just uid
then then
return $ userOverviewPage l10n loc (toEnum $ read method) ud prods return $
userOverviewPage l10n loc (toEnum $ read method) ud prods mcookie
else else
redirectOverAuth redirectOverAuth
(Just uid) (Just uid)
@ -153,7 +154,7 @@ userManageControl mcookie uid = do
(Right userDetails, Right authOverviews) -> (Right userDetails, Right authOverviews) ->
if Just uid == fmap read mAuthUser if Just uid == fmap read mAuthUser
then then
return $ userManagePage l10n loc userDetails authOverviews return $ userManagePage l10n loc userDetails authOverviews mcookie
else else
redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing
err -> handleErrors err -> handleErrors

View file

@ -66,6 +66,30 @@ redirect303 link =
] ]
} }
redirect307
:: Link
-> ServerError
redirect307 link =
err307
{ errHeaders =
[ ("Location", "/" <> fromString (show $ linkURI link))
]
}
addMessage
:: T.Text
-> ServerError
-> ServerError
addMessage message err =
err
{ errHeaders =
( "Set-Cookie"
, "message=" <>
fromString (T.unpack message) <>
"; Path=/; Max-Age=5"
) : errHeaders err
}
parseCookieText parseCookieText
:: T.Text :: T.Text
-> [(T.Text, T.Text)] -> [(T.Text, T.Text)]

View file

@ -27,10 +27,12 @@ authPage
:: L10n :: L10n
-> Locale -> Locale
-> Maybe T.Text -> Maybe T.Text
-> Maybe T.Text
-> AuthPage -> AuthPage
authPage l10n locale mDestination = scaffold authPage l10n locale mDestination mcookie = scaffold
l10n l10n
locale locale
mcookie
(initPage $ (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>

View file

@ -13,7 +13,9 @@ import Data.String (fromString)
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust, fromMaybe)
import Control.Monad (when)
-- imports from mateamt -- imports from mateamt
@ -32,17 +34,26 @@ buyConfirmPage
-> Int -> Int
-> [(MT.PurchaseDetail, MT.ProductShortOverview)] -> [(MT.PurchaseDetail, MT.ProductShortOverview)]
-> Int -> Int
-> Maybe Bool
-> Maybe T.Text
-> H.Html -> H.Html
buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
scaffold l10n locale mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Home" translate "Home"
) $ do ) $ do
if not (fromMaybe False forceBuy)
then
H.p $ H.toHtml $ translate "You are about to buy the following items:" H.p $ H.toHtml $ translate "You are about to buy the following items:"
else
H.p $ H.toHtml $ translate "The following Items seem out of stock:"
H.form H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action H.! HA.action
("/" <> fromString (show $ linkURI $ purchaseCompleteLink uid)) ("/" <> fromString
(show $ linkURI $ purchaseCompleteLink uid forceBuy)
)
H.! HA.enctype "application/x-www-form-urlencoded" H.! HA.enctype "application/x-www-form-urlencoded"
$ do $ do
mapM_ mapM_
@ -105,7 +116,18 @@ buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Buy" $ H.toHtml $ if (fromMaybe False forceBuy)
then translate "Buy anyway"
else translate "Buy"
when (fromMaybe False forceBuy) $
H.button
H.! HA.formnovalidate "formnovalidate"
H.! HA.formmethod "get"
H.! HA.formaction
("/" <> fromString
(show $ linkURI $ userOverviewLink uid Nothing)
)
$ H.toHtml $ translate "Cancel"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext

View file

@ -4,7 +4,7 @@ module View.Scaffold where
import Servant.Links import Servant.Links
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as H import qualified Text.Blaze.Html5.Attributes as HA
import qualified Data.Text as T import qualified Data.Text as T
@ -12,21 +12,33 @@ import Data.String (fromString)
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (fromJust, isJust)
import Control.Monad (when)
-- internal imports -- internal imports
import Types.Page import Types.Page
import API import API
import Util
scaffold scaffold
:: L10n :: L10n
-> Locale -> Locale
-> Maybe T.Text
-> Page H.Html T.Text -> Page H.Html T.Text
-> H.Html -> H.Html
-> H.Html -> H.Html
scaffold l10n locale page content = template page $ do scaffold l10n locale mcookie page content = template page $ do
H.header $ H.nav $ H.ul $ H.header $ H.nav $ H.ul $
H.li $ H.a H.! H.href ("/" <> fromString (show $ linkURI userSelectLink)) $ H.li $ H.a H.! HA.href ("/" <> fromString (show $ linkURI userSelectLink)) $
H.toHtml $ localize l10n locale $ gettext "Home" H.toHtml $ localize l10n locale $ gettext "Home"
H.hr H.hr
H.div H.! H.id "main" H.! H.role "main" $ when (isJust message)
(H.div H.! HA.id "message" H.! HA.class_ "message" $
H.toHtml (fromJust message)
)
H.div H.! HA.id "main" H.! HA.role "main" $
content content
where
message = lookup "message" =<< fmap parseCookieText mcookie

View file

@ -31,8 +31,10 @@ userSelectPage
:: L10n :: L10n
-> Locale -> Locale
-> [MT.UserSummary] -> [MT.UserSummary]
-> Maybe T.Text
-> UserSelectPage -> UserSelectPage
userSelectPage l10n locale uss = scaffold l10n locale (initPage $ userSelectPage l10n locale uss mcookie =
scaffold l10n locale mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Home" translate "Home"
@ -53,8 +55,10 @@ userOverviewPage
-> MT.AuthMethod -> MT.AuthMethod
-> MT.UserDetails -> MT.UserDetails
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> Maybe T.Text
-> UserOverviewPage -> UserOverviewPage
userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $ userOverviewPage l10n locale method ud pos mcookie =
scaffold l10n locale mcookie (initPage $
localize l10n locale (gettext "Matebeamter") <> localize l10n locale (gettext "Matebeamter") <>
" - " <> " - " <>
localize l10n locale (gettext "User Menu for ") <> localize l10n locale (gettext "User Menu for ") <>
@ -83,7 +87,8 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
H.form H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ H.! HA.action ("/" <> (fromString $ show $ linkURI $
buyLink (MT.userDetailsId ud))) buyLink (MT.userDetailsId ud) Nothing)
)
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.enctype "application/x-www-form-urlencoded" $
buyProductsForm l10n locale pos buyProductsForm l10n locale pos
MT.ChallengeResponse -> do MT.ChallengeResponse -> do
@ -91,7 +96,8 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
H.form H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ H.! HA.action ("/" <> (fromString $ show $ linkURI $
buyLink (MT.userDetailsId ud))) buyLink (MT.userDetailsId ud) Nothing)
)
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.enctype "application/x-www-form-urlencoded" $
buyProductsForm l10n locale pos buyProductsForm l10n locale pos
where where
@ -128,8 +134,9 @@ productList pos =
userNewPage userNewPage
:: L10n :: L10n
-> Locale -> Locale
-> Maybe T.Text
-> UserNewPage -> UserNewPage
userNewPage l10n locale = scaffold l10n locale (initPage $ userNewPage l10n locale mcookie = scaffold l10n locale mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Create new user" translate "Create new user"
@ -177,9 +184,10 @@ userManagePage
-> Locale -> Locale
-> MT.UserDetails -> MT.UserDetails
-> [MT.AuthOverview] -> [MT.AuthOverview]
-> Maybe T.Text
-> UserManagePage -> UserManagePage
userManagePage l10n locale userDetails authOverviews = userManagePage l10n locale userDetails authOverviews mcookie =
scaffold l10n locale (initPage $ scaffold l10n locale mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Manage user data" translate "Manage user data"