Pay now with payment intent

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
 

messages/en.msg

@@ -1,3 +1,6 @@
+PaymentIntentCancelled: Payment intent was cancelled
+Pay: Pay
+PaymentAmount: Payment amount
 TotalPrice: Total price
 Completion: Completion
 Checkout: Checkout

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

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ă

messages/ru.msg

@@ -1,3 +1,6 @@
+PaymentIntentCancelled: Намерение платежа было отменено
+Pay: Заплатить
+PaymentAmount: Сумма платежа
 TotalPrice: Итоговая цена
 Completion: Завершение
 Checkout: Оформить заказ

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
     )

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

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

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