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 :> 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"

2
src/Control/Auth.hs
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

69
src/Control/Buy.hs
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

9
src/Control/User.hs
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

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 parseCookieText
:: T.Text :: T.Text
-> [(T.Text, T.Text)] -> [(T.Text, T.Text)]

4
src/View/Auth.hs
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" <>
" - " <> " - " <>

168
src/View/Buy.hs
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,80 +34,100 @@ 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 =
translate "Matebeamter" <> scaffold l10n locale mcookie (initPage $
" - " <> translate "Matebeamter" <>
translate "Home" " - " <>
) $ do translate "Home"
H.p $ H.toHtml $ translate "You are about to buy the following items:" ) $ do
H.form if not (fromMaybe False forceBuy)
H.! HA.method "post" then
H.! HA.action H.p $ H.toHtml $ translate "You are about to buy the following items:"
("/" <> fromString (show $ linkURI $ purchaseCompleteLink uid)) else
H.! HA.enctype "application/x-www-form-urlencoded" H.p $ H.toHtml $ translate "The following Items seem out of stock:"
$ do H.form
mapM_ H.! HA.method "post"
(\( MT.PurchaseDetail pdid amount H.! HA.action
, MT.ProductShortOverview pid ident price _ _ mava) -> ("/" <> fromString
H.div H.! HA.class_ "form-group required" $ do (show $ linkURI $ purchaseCompleteLink uid forceBuy)
H.input
H.! HA.id ("product-select-" <> fromString (show pid))
H.! HA.class_ "form-control"
H.! HA.name ("productSelect-" <> fromString (show pid))
H.! HA.type_ "hidden"
H.! HA.value "true"
H.label
H.! HA.for ("product-amount-" <> fromString (show pid))
$ do
H.img
H.!?
( isJust mava
, HA.src
(fromString $ show $ fromJust mava) -- TODO: ask for avatar
)
H.toHtml ident
H.input
H.! HA.id ("product-amount-" <> (fromString (show pid)))
H.! HA.class_ "form-control"
H.! HA.name ("productAmount-" <> fromString (show pid))
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value (fromString $ show amount)
-- H.! HA.disabled ""
H.label
H.! HA.for ("product-total-" <> fromString (show pid))
$ H.toHtml $
" @ " <> formatMoney price <> "€" -- TODO: ask for currency symbol
H.input
H.! HA.id ("product-total-" <> (fromString (show pid)))
H.! HA.class_ "form-control"
H.! HA.name ("productTotal-" <> fromString (show pid))
H.! HA.type_ "text"
H.! HA.value
(fromString $ T.unpack $ formatMoney $ amount * price)
H.! HA.disabled ""
H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
) )
ziptups H.! HA.enctype "application/x-www-form-urlencoded"
H.div H.! HA.class_ "form-group required" $ do $ do
H.label mapM_
H.! HA.for "total-price" (\( MT.PurchaseDetail pdid amount
$ H.toHtml ("Total price: " :: T.Text) , MT.ProductShortOverview pid ident price _ _ mava) ->
H.input H.div H.! HA.class_ "form-group required" $ do
H.! HA.id "total-price" H.input
H.! HA.class_ "form-control" H.! HA.id ("product-select-" <> fromString (show pid))
H.! HA.name "totalPrice" H.! HA.class_ "form-control"
H.! HA.type_ "text" H.! HA.name ("productSelect-" <> fromString (show pid))
H.! HA.value (fromString $ T.unpack $ formatMoney total) H.! HA.type_ "hidden"
H.! HA.disabled "" H.! HA.value "true"
H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol H.label
H.div H.! HA.class_ "form-group optional" $ H.! HA.for ("product-amount-" <> fromString (show pid))
H.button $ do
H.! HA.class_ "btn btn-default" H.img
H.! HA.type_ "submit" H.!?
$ H.toHtml $ translate "Buy" ( isJust mava
, HA.src
(fromString $ show $ fromJust mava) -- TODO: ask for avatar
)
H.toHtml ident
H.input
H.! HA.id ("product-amount-" <> (fromString (show pid)))
H.! HA.class_ "form-control"
H.! HA.name ("productAmount-" <> fromString (show pid))
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "1"
H.! HA.value (fromString $ show amount)
-- H.! HA.disabled ""
H.label
H.! HA.for ("product-total-" <> fromString (show pid))
$ H.toHtml $
" @ " <> formatMoney price <> "€" -- TODO: ask for currency symbol
H.input
H.! HA.id ("product-total-" <> (fromString (show pid)))
H.! HA.class_ "form-control"
H.! HA.name ("productTotal-" <> fromString (show pid))
H.! HA.type_ "text"
H.! HA.value
(fromString $ T.unpack $ formatMoney $ amount * price)
H.! HA.disabled ""
H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
)
ziptups
H.div H.! HA.class_ "form-group required" $ do
H.label
H.! HA.for "total-price"
$ H.toHtml ("Total price: " :: T.Text)
H.input
H.! HA.id "total-price"
H.! HA.class_ "form-control"
H.! HA.name "totalPrice"
H.! HA.type_ "text"
H.! HA.value (fromString $ T.unpack $ formatMoney total)
H.! HA.disabled ""
H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ 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

20
src/View/Scaffold.hs
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

118
src/View/User.hs
View file

@ -31,19 +31,21 @@ 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 =
translate "Matebeamter" <> scaffold l10n locale mcookie (initPage $
" - " <> translate "Matebeamter" <>
translate "Home" " - " <>
) $ do translate "Home"
mapM_ (\(MT.UserSummary uid ident _) -> ) $ do
H.a H.! HA.href ("/" <> fromString (show $ linkURI $ mapM_ (\(MT.UserSummary uid ident _) ->
userOverviewLink uid Nothing)) $ H.a H.! HA.href ("/" <> fromString (show $ linkURI $
H.toHtml ident userOverviewLink uid Nothing)) $
) uss H.toHtml ident
H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $ ) uss
H.toHtml $ translate "New user" H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
H.toHtml $ translate "New user"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -53,47 +55,51 @@ 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 =
localize l10n locale (gettext "Matebeamter") <> scaffold l10n locale mcookie (initPage $
" - " <> localize l10n locale (gettext "Matebeamter") <>
localize l10n locale (gettext "User Menu for ") <> " - " <>
MT.userDetailsIdent ud localize l10n locale (gettext "User Menu for ") <>
) $ do MT.userDetailsIdent ud
H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud ) $ do
<> "!" H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $ <> "!"
translate "Your current balance is" <> H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
": " <> translate "Your current balance is" <>
formatMoney (MT.userDetailsBalance ud) ": " <>
-- TODO: Add currency symbol formatMoney (MT.userDetailsBalance ud)
H.p $ H.form -- TODO: Add currency symbol
H.! HA.method "post" H.p $ H.form
H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink)) H.! HA.method "post"
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
H.div H.! HA.class_ "form-group optional" $ H.! HA.enctype "application/x-www-form-urlencoded" $
H.button H.div H.! HA.class_ "form-group optional" $
H.! HA.class_ "btn btn-default" H.button
H.! HA.type_ "submit" H.! HA.class_ "btn btn-default"
$ H.toHtml $ translate "Logout" H.! HA.type_ "submit"
case method of $ H.toHtml $ translate "Logout"
MT.PrimaryPass -> case method of
userSettingsPointer l10n locale (MT.userDetailsId ud) MT.PrimaryPass ->
MT.SecondaryPass -> userSettingsPointer l10n locale (MT.userDetailsId ud)
H.form MT.SecondaryPass ->
H.! HA.method "post" H.form
H.! HA.action ("/" <> (fromString $ show $ linkURI $ H.! HA.method "post"
buyLink (MT.userDetailsId ud))) H.! HA.action ("/" <> (fromString $ show $ linkURI $
H.! HA.enctype "application/x-www-form-urlencoded" $ buyLink (MT.userDetailsId ud) Nothing)
buyProductsForm l10n locale pos )
MT.ChallengeResponse -> do H.! HA.enctype "application/x-www-form-urlencoded" $
userSettingsPointer l10n locale (MT.userDetailsId ud) buyProductsForm l10n locale pos
H.form MT.ChallengeResponse -> do
H.! HA.method "post" userSettingsPointer l10n locale (MT.userDetailsId ud)
H.! HA.action ("/" <> (fromString $ show $ linkURI $ H.form
buyLink (MT.userDetailsId ud))) H.! HA.method "post"
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.action ("/" <> (fromString $ show $ linkURI $
buyProductsForm l10n locale pos buyLink (MT.userDetailsId ud) Nothing)
)
H.! HA.enctype "application/x-www-form-urlencoded" $
buyProductsForm l10n locale pos
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -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"