one trainride later

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"

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

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
+          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) ->
-          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) ->
-          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 ->
         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

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

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)]

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

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,17 +34,26 @@ buyConfirmPage
   -> Int
   -> [(MT.PurchaseDetail, MT.ProductShortOverview)]
   -> Int
+  -> Maybe Bool
+  -> Maybe T.Text
   -> H.Html
-buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $
+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))
+          ("/" <> fromString
+            (show $ linkURI $ purchaseCompleteLink uid forceBuy)
+            )
         H.! HA.enctype "application/x-www-form-urlencoded"
         $ do
           mapM_
@@ -105,7 +116,18 @@ buyConfirmPage l10n locale uid ziptups total = scaffold l10n locale (initPage $
             H.button
               H.! HA.class_ "btn btn-default"
               H.! HA.type_ "submit"
-            $ H.toHtml $ translate "Buy"
+              $ 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
 

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

src/View/User.hs

@@ -31,8 +31,10 @@ userSelectPage
   :: L10n
   -> Locale
   -> [MT.UserSummary]
+  -> Maybe T.Text
   -> UserSelectPage
-userSelectPage l10n locale uss = scaffold l10n locale (initPage $
+userSelectPage l10n locale uss mcookie =
+  scaffold l10n locale mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Home"
@@ -53,8 +55,10 @@ userOverviewPage
   -> MT.AuthMethod
   -> MT.UserDetails
   -> [MT.ProductShortOverview]
+  -> Maybe T.Text
   -> UserOverviewPage
-userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
+userOverviewPage l10n locale method ud pos mcookie =
+  scaffold l10n locale mcookie (initPage $
     localize l10n locale (gettext "Matebeamter") <>
     " - " <>
     localize l10n locale (gettext "User Menu for ") <>
@@ -83,7 +87,8 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
           H.form
             H.! HA.method "post"
             H.! HA.action ("/" <> (fromString $ show $ linkURI $
-            buyLink (MT.userDetailsId ud)))
+              buyLink (MT.userDetailsId ud) Nothing)
+              )
             H.! HA.enctype "application/x-www-form-urlencoded" $
               buyProductsForm l10n locale pos
         MT.ChallengeResponse -> do
@@ -91,7 +96,8 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
           H.form
             H.! HA.method "post"
             H.! HA.action ("/" <> (fromString $ show $ linkURI $
-            buyLink (MT.userDetailsId ud)))
+              buyLink (MT.userDetailsId ud) Nothing)
+              )
             H.! HA.enctype "application/x-www-form-urlencoded" $
               buyProductsForm l10n locale pos
   where
@@ -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 =
+userManagePage l10n locale userDetails authOverviews mcookie =
-  scaffold l10n locale (initPage $
+  scaffold l10n locale mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Manage user data"