From 28b98a6f9b892c1ca8936174fd638273f1e7a7fd Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 12 Dec 2019 00:45:22 +0100 Subject: [PATCH] implement cash check functionality --- matebeamter.cabal | 1 + src/API.hs | 6 ++++- src/Client.hs | 1 + src/Control/Journal.hs | 51 ++++++++++++++++++++++++++++++++++++-- src/Main.hs | 3 ++- src/Types.hs | 1 + src/Types/Journal.hs | 18 ++++++++++++++ src/View/Journal.hs | 56 ++++++++++++++++++++++++++++++++++++------ 8 files changed, 126 insertions(+), 11 deletions(-) create mode 100644 src/Types/Journal.hs diff --git a/matebeamter.cabal b/matebeamter.cabal index 72ad6f4..73b4bfe 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -29,6 +29,7 @@ executable matebeamter , Types.Reader , Types.Views , Types.User + , Types.Journal , Types.Orphans , Types.Configuration , Control diff --git a/src/API.hs b/src/API.hs index 44d50b7..6a4abc1 100644 --- a/src/API.hs +++ b/src/API.hs @@ -67,6 +67,9 @@ type UserAPI = :> Get '[HTML] JournalPage :<|> "journal" :> "check" :> Get '[HTML] JournalCheckPage + :<|> "journal" :> "check" + :> ReqBody '[FormUrlEncoded] CashCheck + :> Post '[HTML] JournalPage :<|> "auth" :> QueryParam "destination" T.Text :> Get '[HTML] @@ -97,7 +100,8 @@ type UserAPI = cashBuyLink :<|> cashBuyPostLink :<|> journalLink :<|> - journalCheckLink :<|> + journalGetCheckLink :<|> + journalPostCheckLink :<|> authLink :<|> authPostLink :<|> authLogoutLink diff --git a/src/Client.hs b/src/Client.hs index d32d0c1..6ead7ed 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -121,6 +121,7 @@ avatarList :: ClientM [MT.Avatar] buy :<|> journalShow :<|> + journalPostCashCheck :<|> avatarGet :<|> avatarInsert :<|> diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 1df485f..d7cf909 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -13,6 +13,7 @@ import Control.Monad.IO.Class (liftIO) import Data.String import qualified Data.Text as T +import Data.Text.I18n import Data.Maybe (fromMaybe) @@ -66,8 +67,54 @@ journalControl mcookie mpage = do throwError $ addMessage (fromString $ show othererr) $ redirect303 userSelectLink + Nothing -> + redirectOverAuth Nothing (Just $ journalLink mpage) Nothing -journalCheckControl +journalGetCheckControl :: Maybe T.Text -> 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 diff --git a/src/Main.hs b/src/Main.hs index 8e17d1b..6aafaf6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -83,7 +83,8 @@ userApp initState = serveWithContext userApi EmptyContext $ :<|> cashBuyOverviewControl mcookie :<|> cashBuyPurchaseControl mcookie :<|> journalControl mcookie - :<|> journalCheckControl mcookie + :<|> journalGetCheckControl mcookie + :<|> journalPostCheckControl mcookie :<|> authControl mcookie :<|> authPostControl mcookie :<|> authLogoutControl mcookie diff --git a/src/Types.hs b/src/Types.hs index 63b738c..01a99fe 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -7,5 +7,6 @@ import Types.Page as T import Types.Reader as T import Types.Views as T import Types.User as T +import Types.Journal as T import Types.Orphans as T import Types.Configuration as T diff --git a/src/Types/Journal.hs b/src/Types/Journal.hs new file mode 100644 index 0000000..610528d --- /dev/null +++ b/src/Types/Journal.hs @@ -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 diff --git a/src/View/Journal.hs b/src/View/Journal.hs index adaf230..6c1bba2 100644 --- a/src/View/Journal.hs +++ b/src/View/Journal.hs @@ -34,7 +34,7 @@ journalPage -> Maybe T.Text -> Maybe Word -> [MT.JournalEntry] - -> H.Html + -> JournalPage journalPage l10n loc mcookie mpage entries = scaffold l10n loc mcookie (initPage $ translate "Matebeamter" <> @@ -77,11 +77,53 @@ journalPage l10n loc mcookie mpage entries = (show $ linkURI (journalLink (Just $ page + 1))) ) $ H.toHtml $ translate "Next Page" - H.button - H.! HA.type_ "submit" - H.! HA.formmethod "get" - H.! HA.formaction - ("/" <> fromString (show $ linkURI $ journalCheckLink) - $ H.toHtml $ translate "Perform cash check" + H.form $ + H.button + H.! HA.type_ "submit" + H.! HA.formmethod "get" + H.! HA.formaction + ("/" <> 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 translate = localize l10n loc . gettext