implement cash check functionality

This commit is contained in:
nek0 2019-12-12 00:45:22 +01:00
parent 096f287ce1
commit 28b98a6f9b
8 changed files with 126 additions and 11 deletions

View file

@ -29,6 +29,7 @@ executable matebeamter
, Types.Reader , Types.Reader
, Types.Views , Types.Views
, Types.User , Types.User
, Types.Journal
, Types.Orphans , Types.Orphans
, Types.Configuration , Types.Configuration
, Control , Control

View file

@ -67,6 +67,9 @@ type UserAPI =
:> Get '[HTML] JournalPage :> Get '[HTML] JournalPage
:<|> "journal" :> "check" :<|> "journal" :> "check"
:> Get '[HTML] JournalCheckPage :> Get '[HTML] JournalCheckPage
:<|> "journal" :> "check"
:> ReqBody '[FormUrlEncoded] CashCheck
:> Post '[HTML] JournalPage
:<|> "auth" :<|> "auth"
:> QueryParam "destination" T.Text :> QueryParam "destination" T.Text
:> Get '[HTML] :> Get '[HTML]
@ -97,7 +100,8 @@ type UserAPI =
cashBuyLink :<|> cashBuyLink :<|>
cashBuyPostLink :<|> cashBuyPostLink :<|>
journalLink :<|> journalLink :<|>
journalCheckLink :<|> journalGetCheckLink :<|>
journalPostCheckLink :<|>
authLink :<|> authLink :<|>
authPostLink :<|> authPostLink :<|>
authLogoutLink authLogoutLink

View file

@ -121,6 +121,7 @@ avatarList :: ClientM [MT.Avatar]
buy :<|> buy :<|>
journalShow :<|> journalShow :<|>
journalPostCashCheck :<|>
avatarGet :<|> avatarGet :<|>
avatarInsert :<|> avatarInsert :<|>

View file

@ -13,6 +13,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.String import Data.String
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.I18n
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -66,8 +67,54 @@ journalControl mcookie mpage = do
throwError $ throwError $
addMessage (fromString $ show othererr) $ addMessage (fromString $ show othererr) $
redirect303 userSelectLink redirect303 userSelectLink
Nothing ->
redirectOverAuth Nothing (Just $ journalLink mpage) Nothing
journalCheckControl journalGetCheckControl
:: Maybe T.Text :: Maybe T.Text
-> UserHandler JournalCheckPage -> UserHandler JournalCheckPage
ournalCheckControl journalGetCheckControl mcookie = do
let (token, muser) = parseTokenAndUser mcookie
loc = localeFromCookie mcookie
l10n <- asks rsL10n
return $ journalCheckPage l10n loc mcookie
journalPostCheckControl
:: Maybe T.Text
-> CashCheck
-> UserHandler JournalPage
journalPostCheckControl mcookie (CashCheck floatAmount) = do
let (token, muser) = parseTokenAndUser mcookie
loc = localeFromCookie mcookie
l10n <- asks rsL10n
backend <- asks rsBackend
case muser of
Just user -> do
eresult <- liftIO $ runClientM
(journalPostCashCheck
(mkAuthenticatedRequest token authenticateReq)
(MT.JournalCashCheck $ floor $ floatAmount * 100)
)
backend
case eresult of
Right _ -> throwError $
addMessage (translate l10n loc "Cash check received and processed") $
redirect303 (journalLink Nothing)
Left err ->
case err of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then
redirectOverAuth Nothing (Just $ journalGetCheckLink) Nothing
else
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
otherErr ->
throwError $
addMessage (fromString $ show otherErr) $
redirect303 userSelectLink
Nothing ->
redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing
where
translate l10n locale = localize l10n locale . gettext

View file

@ -83,7 +83,8 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> cashBuyOverviewControl mcookie :<|> cashBuyOverviewControl mcookie
:<|> cashBuyPurchaseControl mcookie :<|> cashBuyPurchaseControl mcookie
:<|> journalControl mcookie :<|> journalControl mcookie
:<|> journalCheckControl mcookie :<|> journalGetCheckControl mcookie
:<|> journalPostCheckControl mcookie
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
:<|> authLogoutControl mcookie :<|> authLogoutControl mcookie

View file

@ -7,5 +7,6 @@ import Types.Page as T
import Types.Reader as T import Types.Reader as T
import Types.Views as T import Types.Views as T
import Types.User as T import Types.User as T
import Types.Journal as T
import Types.Orphans as T import Types.Orphans as T
import Types.Configuration as T import Types.Configuration as T

18
src/Types/Journal.hs Normal file
View file

@ -0,0 +1,18 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.Journal where
import Servant.API
import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded
import GHC.Generics
newtype CashCheck = CashCheck
{ cashCheckAmount :: Float
}
deriving (Show, Generic)
instance MimeUnrender HTML CashCheck
instance FromForm CashCheck

View file

@ -34,7 +34,7 @@ journalPage
-> Maybe T.Text -> Maybe T.Text
-> Maybe Word -> Maybe Word
-> [MT.JournalEntry] -> [MT.JournalEntry]
-> H.Html -> JournalPage
journalPage l10n loc mcookie mpage entries = journalPage l10n loc mcookie mpage entries =
scaffold l10n loc mcookie (initPage $ scaffold l10n loc mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
@ -77,11 +77,53 @@ journalPage l10n loc mcookie mpage entries =
(show $ linkURI (journalLink (Just $ page + 1))) (show $ linkURI (journalLink (Just $ page + 1)))
) )
$ H.toHtml $ translate "Next Page" $ H.toHtml $ translate "Next Page"
H.button H.form $
H.! HA.type_ "submit" H.button
H.! HA.formmethod "get" H.! HA.type_ "submit"
H.! HA.formaction H.! HA.formmethod "get"
("/" <> fromString (show $ linkURI $ journalCheckLink) H.! HA.formaction
$ H.toHtml $ translate "Perform cash check" ("/" <> fromString (show $ linkURI $ journalGetCheckLink))
$ H.toHtml $ translate "Perform cash check"
where
translate = localize l10n loc . gettext
journalCheckPage
:: L10n
-> Locale
-> Maybe T.Text
-> JournalCheckPage
journalCheckPage l10n loc mcookie =
scaffold l10n loc mcookie (initPage $
translate "Matebeamter" <>
" - " <>
translate "Cash check"
) $ do
H.div $ do
H.p $
H.toHtml $ translate $ mconcat
[ "Please count all the cash in stock thoroughly and diligently, "
, "then submit the total amount in the field below."
]
H.p $
H.toHtml $ translate "Thank you for your cooperation."
H.div $ H.p $ H.form
H.! HA.method "post"
H.! HA.action ("/" <> fromString (show $ linkURI journalPostCheckLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ do
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "total" $ H.toHtml $ translate "Total amount"
H.input
H.! HA.id "total"
H.! HA.class_ "form-control"
H.! HA.name "cashCheckAmount"
H.! HA.type_ "number"
H.! HA.min "0"
H.! HA.step "0.01"
H.! HA.value "0"
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where where
translate = localize l10n loc . gettext translate = localize l10n loc . gettext