From 9afd44c51327dc0e004003305c0e2f6b97faf9df Mon Sep 17 00:00:00 2001 From: ciukstar Date: Thu, 30 Nov 2023 03:00:47 +0300 Subject: [PATCH] Pay now with payment intent --- config/routes.yesodroutes | 27 ++-- messages/en.msg | 3 + messages/fr.msg | 3 + messages/ro.msg | 3 + messages/ru.msg | 3 + src/Application.hs | 5 +- src/Foundation.hs | 8 +- src/Handler/Book.hs | 133 ++++++++++++++---- src/Handler/Checkout.hs | 51 ------- src/Handler/Scratch.hs | 14 ++ templates/book/checkout/checkout.hamlet | 8 -- templates/book/checkout/checkout.julius | 119 ---------------- .../book/payment/checkout/checkout.cassius | 15 +- .../book/payment/checkout/checkout.hamlet | 48 ++++++- .../book/payment/checkout/checkout.julius | 45 ++++-- .../scratch.cassius} | 0 templates/scratch/scratch.hamlet | 21 +++ templates/scratch/scratch.julius | 2 + 18 files changed, 262 insertions(+), 246 deletions(-) delete mode 100644 src/Handler/Checkout.hs create mode 100644 src/Handler/Scratch.hs delete mode 100644 templates/book/checkout/checkout.hamlet delete mode 100644 templates/book/checkout/checkout.julius rename templates/{book/checkout/checkout.cassius => scratch/scratch.cassius} (100%) create mode 100644 templates/scratch/scratch.hamlet create mode 100644 templates/scratch/scratch.julius diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index f30f817..a126d39 100644 --- a/config/routes.yesodroutes +++ b/config/routes.yesodroutes @@ -1,7 +1,5 @@ -/create-payment-intent CreatePaymentIntentR POST -/checkout/#UserId CheckoutR GET - +/scratch ScratchR GET /billing/#UserId/billing BillingR GET /billing/#UserId/invoices InvoicesR GET @@ -35,17 +33,18 @@ /appointments/#BookId AppointmentR GET POST /appointments AppointmentsR GET -/book/search BookSearchR GET POST -/book/end BookEndR GET -/book/#UserId/pay-completion BookPayCompletionR GET -/book/#UserId/payment-intent BookPaymentIntentR POST -/book/#UserId/pay-now BookPayNowR GET -/book/#UserId/pay-at-venue BookPayAtVenueR GET -/book/#UserId/pay BookPayR GET POST -/book/customer BookCustomerR GET POST -/book/time BookTimeR GET POST -/book/staff BookStaffR GET POST -/book BookOffersR GET POST +/book/search BookSearchR GET POST +/book/end BookEndR GET +/book/#UserId/pi/#Text BookPaymentIntentCancelR POST +/book/#UserId/pay-completion BookPayCompletionR GET +/book/#UserId/pi/#Int/#Text BookPaymentIntentR POST +/book/#UserId/pay-now BookPayNowR GET +/book/#UserId/pay-at-venue BookPayAtVenueR GET +/book/#UserId/pay BookPayR GET POST +/book/customer BookCustomerR GET POST +/book/time BookTimeR GET POST +/book/staff BookStaffR GET POST +/book BookOffersR GET POST /aboutus AboutUsR GET diff --git a/messages/en.msg b/messages/en.msg index d2a29cb..11bc59a 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -1,3 +1,6 @@ +PaymentIntentCancelled: Payment intent was cancelled +Pay: Pay +PaymentAmount: Payment amount TotalPrice: Total price Completion: Completion Checkout: Checkout diff --git a/messages/fr.msg b/messages/fr.msg index 2e2fcec..fa50754 100644 --- a/messages/fr.msg +++ b/messages/fr.msg @@ -1,3 +1,6 @@ +PaymentIntentCancelled: L'intention de paiement a été annulée +Pay: Payez +PaymentAmount: Montant du paiement TotalPrice: Prix ​​total Completion: Finalisation Checkout: Vérifier diff --git a/messages/ro.msg b/messages/ro.msg index b667c7e..b55aa53 100644 --- a/messages/ro.msg +++ b/messages/ro.msg @@ -1,3 +1,6 @@ +PaymentIntentCancelled: Intenția de plată a fost anulată +Pay: Plătiți +PaymentAmount: Suma de plată TotalPrice: Prețul total Completion: Finalizare Checkout: Verifică diff --git a/messages/ru.msg b/messages/ru.msg index 284c3e9..ac3f10c 100644 --- a/messages/ru.msg +++ b/messages/ru.msg @@ -1,3 +1,6 @@ +PaymentIntentCancelled: Намерение платежа было отменено +Pay: Заплатить +PaymentAmount: Сумма платежа TotalPrice: Итоговая цена Completion: Завершение Checkout: Оформить заказ diff --git a/src/Application.hs b/src/Application.hs index 898498a..b285b43 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -58,7 +58,7 @@ import Demo.DemoDataEN (populateEN) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! -import Handler.Checkout (getCheckoutR, postCreatePaymentIntentR) +import Handler.Scratch (getScratchR) import Handler.Billing ( getBillingR, getInvoicesR ) @@ -87,7 +87,8 @@ import Handler.Book , getBookCustomerR, postBookCustomerR , getBookPayR, postBookPayR , getBookPayAtVenueR - , getBookPayNowR, postBookPaymentIntentR, getBookPayCompletionR + , getBookPayNowR, postBookPaymentIntentR + , postBookPaymentIntentCancelR, getBookPayCompletionR , getBookEndR , getBookSearchR, postBookSearchR ) diff --git a/src/Foundation.hs b/src/Foundation.hs index da466f7..99dab90 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -123,6 +123,8 @@ instance Yesod App where isAuthorized :: Route App -> Bool -> Handler AuthResult + isAuthorized ScratchR _ = return Authorized + isAuthorized (StaticR _) _ = return Authorized isAuthorized (AuthR _) _ = return Authorized @@ -131,9 +133,6 @@ instance Yesod App where isAuthorized RobotsR _ = return Authorized isAuthorized PhotoPlaceholderR _ = return Authorized - - isAuthorized r@(CreatePaymentIntentR) _ = setUltDest r >> isAuthenticated - isAuthorized r@(CheckoutR _) _ = setUltDest r >> isAuthenticated isAuthorized r@(InvoicesR _) _ = setUltDest r >> isAuthenticated isAuthorized r@(BillingR _) _ = setUltDest r >> isAuthenticated @@ -231,8 +230,9 @@ instance Yesod App where isAuthorized ContactR _ = return Authorized isAuthorized BookEndR _ = return Authorized + isAuthorized (BookPaymentIntentCancelR _ _) _ = isAuthenticated isAuthorized (BookPayCompletionR _) _ = isAuthenticated - isAuthorized (BookPaymentIntentR _) _ = isAuthenticated + isAuthorized (BookPaymentIntentR {}) _ = isAuthenticated isAuthorized (BookPayNowR _) _ = isAuthenticated isAuthorized (BookPayAtVenueR _) _ = isAuthenticated isAuthorized (BookPayR _) _ = isAuthenticated diff --git a/src/Handler/Book.hs b/src/Handler/Book.hs index 977b337..6f451f2 100644 --- a/src/Handler/Book.hs +++ b/src/Handler/Book.hs @@ -19,6 +19,7 @@ module Handler.Book , getBookPayNowR , postBookPaymentIntentR , getBookPayCompletionR + , postBookPaymentIntentCancelR , getBookEndR , getBookSearchR , postBookSearchR @@ -33,6 +34,7 @@ import Data.Aeson.Lens (key) import Data.Aeson (object, (.=)) import qualified Data.Aeson as A (Value) import Data.Bifunctor (Bifunctor(second)) +import qualified Data.ByteString as BS (empty) import Data.Either (isLeft) import Data.Maybe (maybeToList, isJust, fromMaybe) import Data.Fixed (Centi) @@ -51,8 +53,10 @@ import Network.Wreq ( postWith, defaults, auth, basicAuth, FormParam ((:=)), responseBody ) import Text.Hamlet (Html) +import Text.Julius (rawJS) import Text.Shakespeare.I18N (renderMessage, SomeMessage (SomeMessage)) import Text.Read (readMaybe) +import Text.Printf (printf) import Yesod.Core ( Yesod(defaultLayout), YesodRequest (reqGetParams), liftHandler @@ -99,7 +103,7 @@ import Foundation , HomeR, AppointmentsR, AppointmentR, ProfileR, ServiceThumbnailR , BookOffersR, BookStaffR, BookTimeR, BookCustomerR, BookPayR , BookPayNowR, BookPayCompletionR, BookPayAtVenueR, BookEndR - , BookSearchR, BookPaymentIntentR + , BookSearchR, BookPaymentIntentR, BookPaymentIntentCancelR ) , AdminR (AdmStaffPhotoR) , AppMessage @@ -120,7 +124,8 @@ import Foundation , MsgUserProfile, MsgNavigationMenu, MsgNoOffersYet, MsgNoOffersFound , MsgNoCategoriesFound, MsgCongratulations, MsgShowMyAppointments , MsgPaymentMethod, MsgPayAtVenue, MsgPayNow, MsgDebitCreditCard, MsgCheckout - , MsgCompletionTime, MsgCompletion, MsgTotalPrice + , MsgCompletionTime, MsgCompletion, MsgTotalPrice, MsgPaymentAmount, MsgPay + , MsgPaymentIntentCancelled ) ) @@ -141,10 +146,21 @@ import Model ) import Menu (menu) + +getBookPayAtVenueR :: UserId -> Handler Html +getBookPayAtVenueR uid = do + user <- maybeAuth + let times = [] + let rids = [] + let oids = [] + let dates = [] -postPaymentR :: Handler Html -postPaymentR = undefined + curr <- getCurrentRoute + + defaultLayout $ do + setTitleI MsgPaymentMethod + -- $( widgetFile "book/payment/payment") getBookPayCompletionR :: UserId -> Handler Html @@ -157,52 +173,107 @@ getBookPayCompletionR uid = do $(widgetFile "book/payment/completion") -postBookPaymentIntentR :: UserId -> Handler A.Value -postBookPaymentIntentR uid = do - let stripeApi = "https://api.stripe.com/v1/payment_intents" +postBookPaymentIntentCancelR :: UserId -> Text -> Handler () +postBookPaymentIntentCancelR uid intent = do + stati <- reqGetParams <$> getRequest + let api = printf "https://api.stripe.com/v1/payment_intents/%s/cancel" intent + sk <- encodeUtf8 . appStripeSk . appSettings <$> getYesod + let opts = defaults & auth ?~ basicAuth sk "" + r <- liftIO $ postWith opts api BS.empty + addMessageI info MsgPaymentIntentCancelled + redirect (BookPayR uid,("pm",pack $ show PayNow) : stati) + + +postBookPaymentIntentR :: UserId -> Int -> Text -> Handler A.Value +postBookPaymentIntentR uid cents currency = do + let api = "https://api.stripe.com/v1/payment_intents" sk <- encodeUtf8 . appStripeSk . appSettings <$> getYesod let opts = defaults & auth ?~ basicAuth sk "" - r <- liftIO $ postWith opts stripeApi [ "amount" := (1300 :: Int) - , "currency" := ("usd" :: Text) - , "payment_method_types[]" := ("card" :: Text) - ] + r <- liftIO $ postWith opts api [ "amount" := cents + , "currency" := currency + , "payment_method_types[]" := ("card" :: Text) + ] + returnJson $ object [ "clientSecret" .= (r ^? responseBody . key "client_secret")] getBookPayNowR :: UserId -> Handler Html getBookPayNowR uid = do + stati <- reqGetParams <$> getRequest user <- maybeAuth pk <- appStripePk . appSettings <$> getYesod - let times = [] - let rids = [] - let oids = [] - let dates = [] - curr <- getCurrentRoute + rids <- filter ((== "rid") . fst) . reqGetParams <$> getRequest + oids <- filter ((== "oid") . fst) . reqGetParams <$> getRequest + dates <- filter ((== "date") . fst) . reqGetParams <$> getRequest + times <- filter ((== "time") . fst) . reqGetParams <$> getRequest + + items <- runDB $ queryItems [] Nothing (toSqlKey . read . unpack . snd <$> oids) + + let amount = sumOf (folded . _1 . _2 . to entityVal . _offerPrice) items + let cents = truncate $ 100 * amount + currency <- maybe "USD" unValue <$> runDB ( selectOne $ do + x <- from $ table @Business + return $ x ^. BusinessCurrency ) + + curr <- getCurrentRoute + formPaymentIntentCancel <- newIdent + sectionPriceTag <- newIdent + formPayment <- newIdent + elementPayment <- newIdent + buttonSubmitPayment <- newIdent + buttonCancelPayment <- newIdent defaultLayout $ do setTitleI MsgCheckout addScriptRemote "https://js.stripe.com/v3/" $(widgetFile "book/payment/checkout/checkout") - -getBookPayAtVenueR :: UserId -> Handler Html -getBookPayAtVenueR uid = do - user <- maybeAuth - let times = [] - let rids = [] - let oids = [] - let dates = [] - curr <- getCurrentRoute - - defaultLayout $ do - setTitleI MsgPaymentMethod - -- $( widgetFile "book/payment/payment") +postBookPayR :: UserId -> Handler Html +postBookPayR uid = do + stati <- reqGetParams <$> getRequest + user <- maybeAuth + rids <- filter ((== "rid") . fst) . reqGetParams <$> getRequest + oids <- filter ((== "oid") . fst) . reqGetParams <$> getRequest + dates <- filter ((== "date") . fst) . reqGetParams <$> getRequest + times <- filter ((== "time") . fst) . reqGetParams <$> getRequest + pms <- filter ((== "pm") . fst) . reqGetParams <$> getRequest -postBookPayR :: UserId -> Handler Html -postBookPayR uid = undefined + let payMethod = (read . unpack . snd <$>) $ LS.head pms + + items <- runDB $ queryItems [] Nothing (toSqlKey . read . unpack . snd <$> oids) + role <- runDB $ selectOne $ do + x :& s <- from $ table @Role `innerJoin` table @Staff `on` (\(x :& s) -> x ^. RoleStaff ==. s ^. StaffId) + where_ $ x ^. RoleId `in_` valList (toSqlKey . read . unpack . snd <$> rids) + return (s,x) + + business <- runDB $ selectOne $ from $ table @Business + currency <- (unValue <$>) <$> runDB ( selectOne $ do + x <- from $ table @Business + return $ x ^. BusinessCurrency ) + + ((fr,fw),et) <- runFormPost $ formPayMethod + payMethod uid stati user + ((read . unpack . snd <$>) $ LS.head dates) + ((read . unpack . snd <$>) $ LS.head times) + business + items items role (maybeToList role) + + case fr of + FormSuccess (items,role,day,time,addr,tzo,tz,Entity uid _,PayNow) -> do + redirect (BookPayNowR uid,stati) + FormSuccess (items,role,day,time,addr,tzo,tz,Entity uid _,PayAtVenue) -> do + redirect (BookPayAtVenueR uid) + _ -> do + msgs <- getMessages + setUltDestCurrent + sectionPriceTag <- newIdent + formPaymentMethod <- newIdent + defaultLayout $ do + setTitleI MsgPaymentMethod + $(widgetFile "book/payment/payment") getBookPayR :: UserId -> Handler Html diff --git a/src/Handler/Checkout.hs b/src/Handler/Checkout.hs deleted file mode 100644 index 331f771..0000000 --- a/src/Handler/Checkout.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Handler.Checkout (getCheckoutR, postCreatePaymentIntentR) where - -import Foundation - ( Handler, Route (CheckoutR) - , App (appSettings) - , AppMessage (MsgCheckout) - ) -import Text.Hamlet (Html) -import Model (UserId) -import Yesod.Core.Widget (addScriptRemote, setTitleI) -import Yesod.Core - ( Yesod(defaultLayout), getYesod, returnJson - ) -import Settings (widgetFile, AppSettings (appStripeSk, appStripePk)) - -import Network.Wreq - ( postWith, defaults, auth, basicAuth, FormParam ((:=)), responseBody - ) -import Data.Text (Text) -import Data.Function ((&)) -import Control.Lens ((?~),(^?)) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson.Lens (key) -import Data.Aeson (Value, object, (.=)) -import Data.Text.Encoding (encodeUtf8) - - -stripeApi :: String -stripeApi = "https://api.stripe.com/v1/payment_intents" - -postCreatePaymentIntentR :: Handler Value -postCreatePaymentIntentR = do - sk <- encodeUtf8 . appStripeSk . appSettings <$> getYesod - let opts = defaults & auth ?~ basicAuth sk "" - r <- liftIO $ postWith opts stripeApi [ "amount" := (1300 :: Int) - , "currency" := ("usd" :: Text) - , "payment_method_types[]" := ("card" :: Text) - ] - returnJson $ object [ "clientSecret" .= (r ^? responseBody . key "client_secret")] - - -getCheckoutR :: UserId -> Handler Html -getCheckoutR uid = do - pk <- appStripePk . appSettings <$> getYesod - defaultLayout $ do - addScriptRemote "https://js.stripe.com/v3/" - setTitleI MsgCheckout - $(widgetFile "book/checkout/checkout") diff --git a/src/Handler/Scratch.hs b/src/Handler/Scratch.hs new file mode 100644 index 0000000..81efa08 --- /dev/null +++ b/src/Handler/Scratch.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Handler.Scratch (getScratchR) where + + +import Foundation (Handler) +import Text.Hamlet (Html) +import Yesod.Core (Yesod(defaultLayout)) +import Settings (widgetFile) + +getScratchR :: Handler Html +getScratchR = do + defaultLayout $(widgetFile "scratch/scratch") diff --git a/templates/book/checkout/checkout.hamlet b/templates/book/checkout/checkout.hamlet deleted file mode 100644 index c9cac2d..0000000 --- a/templates/book/checkout/checkout.hamlet +++ /dev/null @@ -1,8 +0,0 @@ - -
-
-