create endpoint for credit recharge

matebeamter.cabal

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

src/API.hs

@@ -38,6 +38,11 @@ type UserAPI =
     :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
     :> QueryParam "force" Bool
     :> Post '[HTML] UserSelectPage
+  :<|> "user" :> Capture "id" Int :> "recharge"
+    :> Get '[HTML] UserRechargePage
+  :<|> "user" :> Capture "id" Int :> "recharge"
+    :> ReqBody '[FormUrlEncoded] UserRecharge
+    :> Post '[HTML] UserOverviewPage
   :<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage
   :<|> "user" :> Capture "id" Int :> "manage"
     :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
@@ -70,6 +75,8 @@ type UserAPI =
   userOverviewLink :<|>
   buyLink :<|>
   purchaseCompleteLink :<|>
+  userRechargeLink :<|>
+  userPostRechargeLink :<|>
   userManageLink :<|>
   userManageDetailsSubmitLink :<|>
   userManageAuthCreateLink :<|>

src/Control/User.hs

@@ -13,7 +13,7 @@ import Data.String (fromString)
 import qualified Data.Text as T
 import Data.Text.I18n
 
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Either.Combinators (leftToMaybe)
 
 import Control.Monad (void)
@@ -133,14 +133,52 @@ userOverviewControl mcookie uid mRefine = do
         { errBody = fromString (show uerr) <> " " <> fromString (show perr)
         }
 
+userRechargeControl
+  :: Maybe T.Text
+  -> Int
+  -> UserHandler UserRechargePage
+userRechargeControl mcookie uid = do
+  l10n <- asks rsL10n
+  let loc = localeFromCookie mcookie
+  return $ userRechargePage l10n loc mcookie uid
+
+userPostRechargeControl
+  :: Maybe T.Text
+  -> Int
+  -> UserRecharge
+  -> UserHandler UserOverviewPage
+userPostRechargeControl mcookie uid (UserRecharge amount) = do
+  (ReadState l10n backend _) <- ask
+  let loc = localeFromCookie mcookie
+      (token, mauthuser) = parseTokenAndUser mcookie
+  eresult <- liftIO $ runClientM
+    (userRecharge
+      (mkAuthenticatedRequest token authenticateReq)
+      (MT.UserRecharge $ floor $ amount * 100)
+      )
+    backend
+  if isJust mauthuser
+  then
+    case eresult of
+      Right _ -> throwError $
+        (addMessage $ translate l10n loc "Recharge Successful") $
+        redirect303 (userOverviewLink uid Nothing)
+      Left err -> throwError $
+        (addMessage $ translate l10n loc ("An error occured. " <>
+          fromString (show err))) $
+        redirect303 (userRechargeLink uid)
+  else
+    redirectOverAuth (Just uid) (Just (userRechargeLink uid)) Nothing
+  where
+    translate l10n locale = localize l10n locale . gettext
+
 userManageControl
   :: Maybe T.Text
   -> Int
   -> UserHandler UserManagePage
 userManageControl mcookie uid = do
   (ReadState l10n backend _) <- ask
-  let loc = Locale
+  let loc = localeFromCookie mcookie
-        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
       (token, mAuthUser) = parseTokenAndUser mcookie
   eUserDetails <- liftIO $
     runClientM

src/Main.hs

@@ -72,6 +72,8 @@ userApp initState = serveWithContext userApi EmptyContext $
     :<|> userOverviewControl mcookie
     :<|> buyControl mcookie
     :<|> purchaseControl mcookie
+    :<|> userRechargeControl mcookie
+    :<|> userPostRechargeControl mcookie
     :<|> userManageControl mcookie
     :<|> userManageDetailsSubmitControl mcookie
     :<|> userManageAuthCreateControl mcookie

src/Types.hs

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

src/Types/User.hs

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

src/Types/Views.hs

@@ -8,6 +8,8 @@ type UserNewPage = H.Html
 
 type UserOverviewPage = H.Html
 
+type UserRechargePage = H.Html
+
 type UserManagePage = H.Html
 
 type ProductListPage = H.Html

src/Util.hs

@@ -15,6 +15,8 @@ import qualified Text.Blaze.Html5.Attributes as HA
 import qualified Data.Text as T
 import Data.Text.Lazy.Encoding
 
+import Data.Text.I18n
+
 import Data.ByteString.Builder
 
 import Data.List (intercalate)
@@ -109,6 +111,12 @@ parseTokenAndUser mcookie =
       (lookup "x-auth-user" =<< mParsedCookie)
     mParsedCookie = fmap parseCookieText mcookie
 
+localeFromCookie
+  :: Maybe T.Text
+  -> Locale
+localeFromCookie mcookie = Locale
+  (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
+
 handleErrors
   :: (Traversable t, Show (t (Maybe ClientError)))
   => Maybe Int

src/View/User.hs

@@ -84,15 +84,21 @@ userOverviewPage l10n locale method ud pos mcookie =
         MT.PrimaryPass ->
           userSettingsPointer l10n locale (MT.userDetailsId ud)
         MT.SecondaryPass ->
-          H.form
+          buyForm
-            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)
+          buyForm
+  where
+    translate = localize l10n locale . gettext
+    buyForm = do
+      H.div $ H.form $
+        H.button
+          H.! HA.type_ "submit"
+          H.! HA.formmethod "get"
+          H.! HA.formaction ("/" <>
+            fromString
+              (show $ linkURI $ userRechargeLink $ MT.userDetailsId ud))
+          $ H.toHtml $ translate "Recharge Credit"
       H.form
         H.! HA.method "post"
         H.! HA.action ("/" <> (fromString $ show $ linkURI $
@@ -100,8 +106,6 @@ userOverviewPage l10n locale method ud pos mcookie =
           )
         H.! HA.enctype "application/x-www-form-urlencoded" $
           buyProductsForm l10n locale pos
-  where
-    translate = localize l10n locale . gettext
 
 userSettingsPointer
   :: L10n
@@ -179,6 +183,41 @@ userNewPage l10n locale mcookie = scaffold l10n locale mcookie (initPage $
   where
     translate = localize l10n locale . gettext
 
+userRechargePage
+  :: L10n
+  -> Locale
+  -> Maybe T.Text
+  -> Int
+  -> UserRechargePage
+userRechargePage l10n locale mcookie uid =
+  scaffold l10n locale mcookie (initPage $
+    translate "Matebeamter" <>
+    " - " <>
+    translate "Recharge account"
+    ) $ H.p $ H.form
+      H.! HA.method "post"
+      H.! HA.action ("/" <>
+        fromString (show $ linkURI $ userPostRechargeLink uid))
+      H.! HA.enctype "aplication/x-www-form-urlencoded" $ do
+        H.div H.! HA.class_ "form-group required" $ do
+          H.label H.! HA.for "recharge-amount" $ H.toHtml $ translate "Amount"
+          H.input
+            H.! HA.id "recharde-amount"
+            H.! HA.class_ "form-control"
+            H.! HA.name "userRechargeAmount"
+            H.! HA.type_ "number"
+            H.! HA.min "0"
+            H.! HA.step "0.01"
+            H.! HA.value "0"
+          -- 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 "Recharge"
+  where
+    translate = localize l10n locale . gettext
+
 userManagePage
   :: L10n
   -> Locale