implement cash check functionality

matebeamter.cabal

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

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

src/Client.hs

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

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

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

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

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

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.form $
         H.button
           H.! HA.type_ "submit"
           H.! HA.formmethod "get"
           H.! HA.formaction
-          ("/" <> fromString (show $ linkURI $ journalCheckLink)
+            ("/" <> 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