one trainride later

2019-10-24 18:05:22 +02:00 · 2019-10-24 18:05:22 +02:00 · 96304fe665
commit 96304fe665
parent f41aab662a
9 changed files with 247 additions and 169 deletions
--- a/src/API.hs
+++ b/src/API.hs
@ -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"
--- a/src/Control/Auth.hs
+++ b/src/Control/Auth.hs
@ -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
--- a/src/Control/Buy.hs
+++ b/src/Control/Buy.hs
@ -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
--- a/src/Control/User.hs
+++ b/src/Control/User.hs
@ -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
--- a/src/Util.hs
+++ b/src/Util.hs
@ -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)]
--- a/src/View/Auth.hs
+++ b/src/View/Auth.hs
@ -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" <>
    " - " <>
--- a/src/View/Buy.hs
+++ b/src/View/Buy.hs
@ -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,80 +34,100 @@ buyConfirmPage
  -> Int
  -> [(MT.PurchaseDetail, MT.ProductShortOverview)]
  -> Int
+  -> Maybe Bool
+  -> Maybe T.Text
  -> H.Html
-buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $
-  translate "Matebeamter" <>
-  " - " <>
-  translate "Home"
-  ) $ do
-    H.p $ H.toHtml $ translate "You are about to buy the following items:"
-    H.form
-      H.! HA.method "post"
-      H.! HA.action
-        ("/" <> fromString (show $ linkURI $ purchaseCompleteLink uid))
-      H.! HA.enctype "application/x-www-form-urlencoded"
-      $ do
-        mapM_
-          (\( MT.PurchaseDetail pdid amount
-            , MT.ProductShortOverview pid ident price _ _ mava) ->
-              H.div H.! HA.class_ "form-group required" $ do
-                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
+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 forceBuy)
            )
-          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 $ translate "Buy"
+        H.! HA.enctype "application/x-www-form-urlencoded"
+        $ do
+          mapM_
+            (\( MT.PurchaseDetail pdid amount
+              , MT.ProductShortOverview pid ident price _ _ mava) ->
+                H.div H.! HA.class_ "form-group required" $ do
+                  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.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
    translate = localize l10n locale . gettext

--- a/src/View/Scaffold.hs
+++ b/src/View/Scaffold.hs
@ -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
--- a/src/View/User.hs
+++ b/src/View/User.hs
@ -31,19 +31,21 @@ userSelectPage
  :: L10n
  -> Locale
  -> [MT.UserSummary]
+  -> Maybe T.Text
  -> UserSelectPage
-userSelectPage l10n locale uss = scaffold l10n locale (initPage $
-  translate "Matebeamter" <>
-  " - " <>
-  translate "Home"
-  ) $ do
-    mapM_ (\(MT.UserSummary uid ident _) ->
-      H.a H.! HA.href ("/" <> fromString (show $ linkURI $
-        userOverviewLink uid Nothing)) $
-          H.toHtml ident
-      ) uss
-    H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
-      H.toHtml $ translate "New user"
+userSelectPage l10n locale uss mcookie =
+  scaffold l10n locale mcookie (initPage $
+    translate "Matebeamter" <>
+    " - " <>
+    translate "Home"
+    ) $ do
+      mapM_ (\(MT.UserSummary uid ident _) ->
+        H.a H.! HA.href ("/" <> fromString (show $ linkURI $
+          userOverviewLink uid Nothing)) $
+            H.toHtml ident
+        ) uss
+      H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
+        H.toHtml $ translate "New user"
  where
    translate = localize l10n locale . gettext

@ -53,47 +55,51 @@ userOverviewPage
  -> MT.AuthMethod
  -> MT.UserDetails
  -> [MT.ProductShortOverview]
+  -> Maybe T.Text
  -> UserOverviewPage
-userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
-  localize l10n locale (gettext "Matebeamter") <>
-  " - " <>
-  localize l10n locale (gettext "User Menu for ") <>
-  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" <>
-      ": " <>
-      formatMoney (MT.userDetailsBalance ud)
-      -- TODO: Add currency symbol
-    H.p $ H.form
-      H.! HA.method "post"
-      H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
-      H.! HA.enctype "application/x-www-form-urlencoded" $
-        H.div H.! HA.class_ "form-group optional" $
-          H.button
-            H.! HA.class_ "btn btn-default"
-            H.! HA.type_ "submit"
-            $ H.toHtml $ translate "Logout"
-    case method of
-      MT.PrimaryPass ->
-        userSettingsPointer l10n locale (MT.userDetailsId ud)
-      MT.SecondaryPass ->
-        H.form
-          H.! HA.method "post"
-          H.! HA.action ("/" <> (fromString $ show $ linkURI $
-            buyLink (MT.userDetailsId ud)))
-          H.! HA.enctype "application/x-www-form-urlencoded" $
-            buyProductsForm l10n locale pos
-      MT.ChallengeResponse -> do
-        userSettingsPointer l10n locale (MT.userDetailsId ud)
-        H.form
-          H.! HA.method "post"
-          H.! HA.action ("/" <> (fromString $ show $ linkURI $
-            buyLink (MT.userDetailsId ud)))
-          H.! HA.enctype "application/x-www-form-urlencoded" $
-            buyProductsForm l10n locale pos
+userOverviewPage l10n locale method ud pos mcookie =
+  scaffold l10n locale mcookie (initPage $
+    localize l10n locale (gettext "Matebeamter") <>
+    " - " <>
+    localize l10n locale (gettext "User Menu for ") <>
+    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" <>
+        ": " <>
+        formatMoney (MT.userDetailsBalance ud)
+        -- TODO: Add currency symbol
+      H.p $ H.form
+        H.! HA.method "post"
+        H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
+        H.! HA.enctype "application/x-www-form-urlencoded" $
+          H.div H.! HA.class_ "form-group optional" $
+            H.button
+              H.! HA.class_ "btn btn-default"
+              H.! HA.type_ "submit"
+              $ H.toHtml $ translate "Logout"
+      case method of
+        MT.PrimaryPass ->
+          userSettingsPointer l10n locale (MT.userDetailsId ud)
+        MT.SecondaryPass ->
+          H.form
+            H.! HA.method "post"
+            H.! HA.action ("/" <> (fromString $ show $ linkURI $
+              buyLink (MT.userDetailsId ud) Nothing)
+              )
+            H.! HA.enctype "application/x-www-form-urlencoded" $
+              buyProductsForm l10n locale pos
+        MT.ChallengeResponse -> do
+          userSettingsPointer l10n locale (MT.userDetailsId ud)
+          H.form
+            H.! HA.method "post"
+            H.! HA.action ("/" <> (fromString $ show $ linkURI $
+              buyLink (MT.userDetailsId ud) Nothing)
+              )
+            H.! HA.enctype "application/x-www-form-urlencoded" $
+              buyProductsForm l10n locale pos
  where
    translate = localize l10n locale . gettext

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