nek0/matebeamter
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

one trainride later

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/API.hs
View file

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

2
src/Control/Auth.hs
View file

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

69
src/Control/Buy.hs
View file

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

9
src/Control/User.hs
View file

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

24
src/Util.hs
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
:: T.Text
-> [(T.Text, T.Text)]

4
src/View/Auth.hs
View file

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

30
src/View/Buy.hs
View file

@ -13,7 +13,9 @@ import Data.String (fromString)
import Data.Text.I18n
import Data.Maybe (isJust, fromJust)
import Data.Maybe (isJust, fromJust, fromMaybe)
import Control.Monad (when)
-- imports from mateamt
@ -32,17 +34,26 @@ buyConfirmPage
-> Int
-> [(MT.PurchaseDetail, MT.ProductShortOverview)]
-> Int
-> Maybe Bool
-> Maybe T.Text
-> 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 "Home"
) $ do
if not (fromMaybe False forceBuy)
then
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.! HA.method "post"
H.! HA.action
("/" <> fromString (show $ linkURI $ purchaseCompleteLink uid))
("/" <> fromString
(show $ linkURI $ purchaseCompleteLink uid forceBuy)
)
H.! HA.enctype "application/x-www-form-urlencoded"
$ do
mapM_
@ -105,7 +116,18 @@ buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $
H.button
H.! HA.class_ "btn btn-default"
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
translate = localize l10n locale . gettext

20
src/View/Scaffold.hs
View file

@ -4,7 +4,7 @@ module View.Scaffold where
import Servant.Links
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
@ -12,21 +12,33 @@ import Data.String (fromString)
import Data.Text.I18n
import Data.Maybe (fromJust, isJust)
import Control.Monad (when)
-- internal imports
import Types.Page
import API
import Util
scaffold
:: L10n
-> Locale
-> Maybe T.Text
-> Page H.Html T.Text
-> 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.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.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
where
message = lookup "message" =<< fmap parseCookieText mcookie

22
src/View/User.hs
View file

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