diff --git a/Dockerfile b/Dockerfile index 13eab01..660b3ea 100644 --- a/Dockerfile +++ b/Dockerfile @@ -4,10 +4,22 @@ RUN mkdir -p /opt/salon \ && apt-get install -y --no-install-recommends build-essential zlib1g-dev libpq-dev libicu-dev \ && apt-get clean \ && rm -rf /var/lib/apt/lists/* + +ARG YESOD_DEMO_LANG=EN +ARG YESOD_MAPBOX_PK +ARG YESOD_STRIPE_PK +ARG YESOD_STRIPE_SK + WORKDIR /opt/salon COPY salon /opt/salon COPY static /opt/salon/static COPY config /opt/salon/config -ENV YESOD_PORT=8080 YESOD_DEMO_LANG=EN + +ENV YESOD_PORT=8080 +ENV YESOD_DEMO_LANG=${YESOD_DEMO_LANG} +ENV YESOD_MAPBOX_PK=${YESOD_MAPBOX_PK} +ENV YESOD_STRIPE_PK=${YESOD_STRIPE_PK} +ENV YESOD_STRIPE_SK=${YESOD_STRIPE_SK} + EXPOSE 8080 CMD ["./salon"] diff --git a/DockerfileFR b/DockerfileFR deleted file mode 100644 index 2bc81c2..0000000 --- a/DockerfileFR +++ /dev/null @@ -1,13 +0,0 @@ -FROM ubuntu:22.04 -RUN mkdir -p /opt/salon \ - && apt-get update \ - && apt-get install -y --no-install-recommends build-essential zlib1g-dev libpq-dev libicu-dev \ - && apt-get clean \ - && rm -rf /var/lib/apt/lists/* -WORKDIR /opt/salon -COPY salon /opt/salon -COPY static /opt/salon/static -COPY config /opt/salon/config -ENV YESOD_PORT=8080 YESOD_DEMO_LANG=FR -EXPOSE 8080 -CMD ["./salon"] diff --git a/DockerfileRO b/DockerfileRO deleted file mode 100644 index b071553..0000000 --- a/DockerfileRO +++ /dev/null @@ -1,13 +0,0 @@ -FROM ubuntu:22.04 -RUN mkdir -p /opt/salon \ - && apt-get update \ - && apt-get install -y --no-install-recommends build-essential zlib1g-dev libpq-dev libicu-dev \ - && apt-get clean \ - && rm -rf /var/lib/apt/lists/* -WORKDIR /opt/salon -COPY salon /opt/salon -COPY static /opt/salon/static -COPY config /opt/salon/config -ENV YESOD_PORT=8080 YESOD_DEMO_LANG=RO -EXPOSE 8080 -CMD ["./salon"] diff --git a/DockerfileRU b/DockerfileRU deleted file mode 100644 index 8b7f96f..0000000 --- a/DockerfileRU +++ /dev/null @@ -1,13 +0,0 @@ -FROM ubuntu:22.04 -RUN mkdir -p /opt/salon \ - && apt-get update \ - && apt-get install -y --no-install-recommends build-essential zlib1g-dev libpq-dev libicu-dev \ - && apt-get clean \ - && rm -rf /var/lib/apt/lists/* -WORKDIR /opt/salon -COPY salon /opt/salon -COPY static /opt/salon/static -COPY config /opt/salon/config -ENV YESOD_PORT=8080 YESOD_DEMO_LANG=RU -EXPOSE 8080 -CMD ["./salon"] diff --git a/README.fr.md b/README.fr.md index 2693024..beb0659 100644 --- a/README.fr.md +++ b/README.fr.md @@ -49,6 +49,18 @@ Tout utilisateur également enregistré en tant que membre du personnel a le rô Tous les utilisateurs peuvent devenir clients par simple inscription et utilisation des services proposés. +## Intégration avec des API externes + +* Passerelle de paiement: [Stripe](https://stripe.com/) +``` +ENV: YESOD_STRIPE_PK, YESOD_STRIPE_SK +``` + +* Cartes en ligne: [Mapbox](https://www.mapbox.com/) +``` +ENV: YESOD_MAPBOX_PK +``` + ## Diagramme ERD ![Diagramme entité-relation](static/img/Salon-ERD.svg) diff --git a/README.md b/README.md index 23408c7..36ee94b 100644 --- a/README.md +++ b/README.md @@ -50,6 +50,17 @@ Any user who is also registered as a staff member has the role "Employee". A use All users can become customers by simply registering and using the services offered. +## Integration with external APIs + +* Payment gateway: [Stripe](https://stripe.com/) +``` +ENV: YESOD_STRIPE_PK, YESOD_STRIPE_SK +``` +* Online maps: [Mapbox](https://www.mapbox.com/) +``` +ENV: YESOD_MAPBOX_PK +``` + ## ERD Diagram ![Entity Relationship Diagram](static/img/Salon-ERD.svg) diff --git a/README.ro.md b/README.ro.md index ac9d8b5..a13ae20 100644 --- a/README.ro.md +++ b/README.ro.md @@ -49,6 +49,17 @@ Orice utilizator care este înregistrat și ca membru al personalului are rolul Toți utilizatorii pot deveni clienți prin simpla înregistrare și utilizarea serviciilor oferite. +## Integrare cu API-uri externe +* Gateway de plată: [Stripe](https://stripe.com/) +``` +ENV: YESOD_STRIPE_PK, YESOD_STRIPE_SK +``` + +* Hărți online: [Mapbox](https://www.mapbox.com/) +``` +ENV: YESOD_MAPBOX_PK +``` + ## Diagrama ERD diff --git a/README.ru.md b/README.ru.md index 8a31ab4..61afe8b 100644 --- a/README.ru.md +++ b/README.ru.md @@ -49,6 +49,17 @@ Все пользователи могут стать клиентами, просто зарегистрировавшись и воспользовавшись предлагаемыми услугами. +## Интеграция с внешними API +* Платежный шлюз: [Stripe](https://stripe.com/) +``` +ENV: YESOD_STRIPE_PK, YESOD_STRIPE_SK +``` + +* Онлайн карты: [Mapbox](https://www.mapbox.com/) +``` +ENV: YESOD_MAPBOX_PK +``` + ## ER-диаграмма ![Диаграмма отношений сущностей](static/img/Salon-ERD.svg) diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index a126d39..66a76c2 100644 --- a/config/routes.yesodroutes +++ b/config/routes.yesodroutes @@ -35,11 +35,10 @@ /book/search BookSearchR GET POST /book/end BookEndR GET -/book/#UserId/pi/#Text BookPaymentIntentCancelR POST +/book/#UserId/pi/cancel 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 diff --git a/messages/en.msg b/messages/en.msg index 11bc59a..9ee9bc2 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -1,3 +1,5 @@ +OnlineMaps: Online maps +PaymentGateway: Payment gateway PaymentIntentCancelled: Payment intent was cancelled Pay: Pay PaymentAmount: Payment amount @@ -409,4 +411,6 @@ Doc012: An administrator can assign the role "Analyst" to any other registered u Doc013: Any user who is also registered as a staff member has the role "Employee". A user with the role "Employee" has access to the service request queue. -Doc014: All users can become customers by simply registering and using the services offered. \ No newline at end of file +Doc014: All users can become customers by simply registering and using the services offered. + +Doc015: Integration with external APIs \ No newline at end of file diff --git a/messages/fr.msg b/messages/fr.msg index fa50754..8033a53 100644 --- a/messages/fr.msg +++ b/messages/fr.msg @@ -1,3 +1,5 @@ +OnlineMaps: Cartes en ligne +PaymentGateway: Passerelle de paiement PaymentIntentCancelled: L'intention de paiement a été annulée Pay: Payez PaymentAmount: Montant du paiement @@ -411,4 +413,6 @@ Doc012: Un administrateur peut attribuer le rôle « Analyste » à tout autre Doc013: Tout utilisateur également enregistré en tant que membre du personnel a le rôle "Employé". Un utilisateur avec le rôle « Employé » a accès à la file d'attente des demandes de service. -Doc014: Tous les utilisateurs peuvent devenir clients par simple inscription et utilisation des services proposés. \ No newline at end of file +Doc014: Tous les utilisateurs peuvent devenir clients par simple inscription et utilisation des services proposés. + +Doc015: Intégration avec des API externes \ No newline at end of file diff --git a/messages/ro.msg b/messages/ro.msg index b55aa53..7dffd12 100644 --- a/messages/ro.msg +++ b/messages/ro.msg @@ -1,3 +1,5 @@ +OnlineMaps: Hărți online +PaymentGateway: Gateway de plată PaymentIntentCancelled: Intenția de plată a fost anulată Pay: Plătiți PaymentAmount: Suma de plată @@ -411,4 +413,6 @@ Doc012: Un administrator poate atribui rolul „Analist” oricărui alt utiliza Doc013: Orice utilizator care este înregistrat și ca membru al personalului are rolul „Angajat”. Un utilizator cu rolul „Angajat” are acces la coada de solicitări de servicii. -Doc014: Toți utilizatorii pot deveni clienți prin simpla înregistrare și utilizarea serviciilor oferite. \ No newline at end of file +Doc014: Toți utilizatorii pot deveni clienți prin simpla înregistrare și utilizarea serviciilor oferite. + +Doc015: Integrare cu API-uri externe \ No newline at end of file diff --git a/messages/ru.msg b/messages/ru.msg index ac3f10c..1db5932 100644 --- a/messages/ru.msg +++ b/messages/ru.msg @@ -1,3 +1,5 @@ +OnlineMaps: Онлайн карты +PaymentGateway: Платежный шлюз PaymentIntentCancelled: Намерение платежа было отменено Pay: Заплатить PaymentAmount: Сумма платежа @@ -411,4 +413,6 @@ Doc012: Администратор может назначить роль «Ан Doc013: Любой пользователь, который также зарегистрирован как сотрудник, имеет роль «Сотрудник». Пользователь с ролью «Сотрудник» имеет доступ к очереди запросов на обслуживание. -Doc014: Все пользователи могут стать клиентами, просто зарегистрировавшись и воспользовавшись предлагаемыми услугами. \ No newline at end of file +Doc014: Все пользователи могут стать клиентами, просто зарегистрировавшись и воспользовавшись предлагаемыми услугами. + +Doc015: Интеграция с внешними API \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index b285b43..620cfb5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -86,7 +86,6 @@ import Handler.Book , getBookTimeR, postBookTimeR , getBookCustomerR, postBookCustomerR , getBookPayR, postBookPayR - , getBookPayAtVenueR , getBookPayNowR, postBookPaymentIntentR , postBookPaymentIntentCancelR, getBookPayCompletionR , getBookEndR diff --git a/src/Foundation.hs b/src/Foundation.hs index 99dab90..8ca7d8d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -230,11 +230,10 @@ instance Yesod App where isAuthorized ContactR _ = return Authorized isAuthorized BookEndR _ = return Authorized - isAuthorized (BookPaymentIntentCancelR _ _) _ = isAuthenticated + isAuthorized (BookPaymentIntentCancelR _) _ = isAuthenticated isAuthorized (BookPayCompletionR _) _ = isAuthenticated isAuthorized (BookPaymentIntentR {}) _ = isAuthenticated isAuthorized (BookPayNowR _) _ = isAuthenticated - isAuthorized (BookPayAtVenueR _) _ = isAuthenticated isAuthorized (BookPayR _) _ = isAuthenticated isAuthorized BookCustomerR _ = return Authorized isAuthorized BookTimeR _ = return Authorized diff --git a/src/Handler/Book.hs b/src/Handler/Book.hs index 6f451f2..e72dce6 100644 --- a/src/Handler/Book.hs +++ b/src/Handler/Book.hs @@ -15,7 +15,6 @@ module Handler.Book , postBookCustomerR , getBookPayR , postBookPayR - , getBookPayAtVenueR , getBookPayNowR , postBookPaymentIntentR , getBookPayCompletionR @@ -27,17 +26,17 @@ module Handler.Book ) where import Control.Lens ((?~),(^?), sumOf, folded, _1, _2, to) -import Control.Monad (unless, when, join) +import Control.Monad (unless, when, join, forM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ReaderT) -import Data.Aeson.Lens (key) import Data.Aeson (object, (.=)) +import Data.Aeson.Lens (key) +import Data.Aeson.Text (encodeToLazyText) 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) import Data.Function ((&)) import qualified Data.List.Safe as LS (head) import Data.Text (unpack, intercalate, pack, Text) @@ -62,8 +61,8 @@ import Yesod.Core ( Yesod(defaultLayout), YesodRequest (reqGetParams), liftHandler , getYesod, languages, whamlet, setUltDestCurrent, getMessages , redirect, getRequest, addMessageI, lookupSession - , setSession, getPostParams, newIdent, getCurrentRoute - , returnJson + , setSession, getPostParams, newIdent + , returnJson, deleteSession, getUrlRenderParams ) import Yesod.Core.Widget (setTitleI, addScriptRemote) import Yesod.Auth (maybeAuth, Route (LoginR)) @@ -85,7 +84,8 @@ import Yesod.Form.Input (iopt, runInputGet, ireq) import Settings (widgetFile, AppSettings (appStripePk, appStripeSk)) import Yesod.Persist.Core (runDB) -import Database.Persist ( Entity(Entity, entityVal), PersistStoreWrite (insert, insert_) ) +import Database.Persist + ( Entity(Entity, entityVal, entityKey), PersistStoreWrite (insert, insert_) ) import Database.Persist.Sql ( fromSqlKey, toSqlKey, SqlBackend ) import Database.Esqueleto.Experimental @@ -102,7 +102,7 @@ import Foundation ( AuthR, PhotoPlaceholderR, AccountPhotoR, AdminR, AccountR , HomeR, AppointmentsR, AppointmentR, ProfileR, ServiceThumbnailR , BookOffersR, BookStaffR, BookTimeR, BookCustomerR, BookPayR - , BookPayNowR, BookPayCompletionR, BookPayAtVenueR, BookEndR + , BookPayNowR, BookPayCompletionR, BookEndR , BookSearchR, BookPaymentIntentR, BookPaymentIntentCancelR ) , AdminR (AdmStaffPhotoR) @@ -132,7 +132,8 @@ import Foundation import Model ( EmplStatus (EmplStatusAvailable), Service(Service), ServiceId , Offer (Offer), OfferId, Staff (Staff, staffName) - , RoleId, Role (Role, roleName), UserId, User (User), Book (Book) + , RoleId, Role (Role, roleName), UserId, User (User) + , Book (Book, bookDay, bookTime, bookAddr, bookTzo, bookTz) , Thumbnail, BookStatus (BookStatusRequest), Hist (Hist) , Business (businessAddr, businessTzo, businessTz, Business) , PayMethod (PayAtVenue, PayNow) @@ -146,84 +147,124 @@ import Model ) import Menu (menu) - -getBookPayAtVenueR :: UserId -> Handler Html -getBookPayAtVenueR uid = do + +getBookPayCompletionR :: UserId -> Handler Html +getBookPayCompletionR uid = do user <- maybeAuth - let times = [] - let rids = [] - let oids = [] - let dates = [] - curr <- getCurrentRoute + oids <- filter ((== "oid") . fst) . reqGetParams <$> getRequest + rid <- (toSqlKey <$>) <$> runInputGet ( iopt intField "rid" ) + day <- runInputGet $ ireq dayField "date" + time <- runInputGet $ ireq timeField "time" + addr <- runInputGet $ ireq textareaField "addr" + tzo <- minutesToTimeZone <$> runInputGet ( ireq intField "tzo" ) + tz <- runInputGet $ ireq textField "tz" - defaultLayout $ do - setTitleI MsgPaymentMethod - -- $( widgetFile "book/payment/payment") + _ <- runInputGet $ ireq textField "payment_intent" + _ <- runInputGet $ ireq textField "payment_intent_client_secret" + _ <- runInputGet $ ireq textField "redirect_status" + currency <- (unValue <$>) <$> runDB ( selectOne $ do + x <- from $ table @Business + return $ x ^. BusinessCurrency ) + + items <- runDB $ queryItems [] Nothing (toSqlKey . read . unpack . snd <$> oids) -getBookPayCompletionR :: UserId -> Handler Html -getBookPayCompletionR uid = do - pi <- runInputGet $ ireq textField "payment_intent" - pics <- runInputGet $ ireq textField "payment_intent_client_secret" - rdrs <- runInputGet $ ireq textField "redirect_status" + role <- case rid of + Just x -> runDB $ queryRole [x] + _ -> return Nothing + + bids <- forM items $ \((_,Entity oid _),_) -> do + let book = Book uid oid rid day time addr tzo tz PayNow BookStatusRequest + bid <- runDB $ insert book + now <- liftIO getCurrentTime + runDB $ insert_ $ Hist bid uid now + (bookDay book) (bookTime book) (bookAddr book) (bookTzo book) (bookTz book) BookStatusRequest + (roleName . entityVal . snd <$> role) (staffName . entityVal . fst <$> role) + return bid + addMessageI info MsgRecordAdded + deleteSession sessKeyBooking + + books <- runDB $ select $ do + x :& o :& s <- from $ table @Book + `innerJoin` table @Offer `on` (\(x :& o) -> x ^. BookOffer ==. o ^. OfferId) + `innerJoin` table @Service `on` (\(_ :& o :& s) -> o ^. OfferService ==. s ^. ServiceId) + where_ $ s ^. ServicePublished + where_ $ o ^. OfferPublished + where_ $ x ^. BookCustomer ==. val uid + where_ $ x ^. BookId `in_` valList bids + return (x,o,s) + + msgs <- getMessages + detailsBooks <- newIdent defaultLayout $ do setTitleI MsgCompletion $(widgetFile "book/payment/completion") -postBookPaymentIntentCancelR :: UserId -> Text -> Handler () -postBookPaymentIntentCancelR uid intent = do - stati <- reqGetParams <$> getRequest - let api = printf "https://api.stripe.com/v1/payment_intents/%s/cancel" intent +postBookPaymentIntentCancelR :: UserId -> Handler () +postBookPaymentIntentCancelR uid = do + stati <- reqGetParams <$> getRequest + intent <- runInputGet $ ireq textField "pi" sk <- encodeUtf8 . appStripeSk . appSettings <$> getYesod - let opts = defaults & auth ?~ basicAuth sk "" - r <- liftIO $ postWith opts api BS.empty + _ <- liftIO $ postWith + (defaults & auth ?~ basicAuth sk BS.empty) + (printf "https://api.stripe.com/v1/payment_intents/%s/cancel" intent) + 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 +postBookPaymentIntentR _ cents currency = do let api = "https://api.stripe.com/v1/payment_intents" sk <- encodeUtf8 . appStripeSk . appSettings <$> getYesod - let opts = defaults & auth ?~ basicAuth sk "" + let opts = defaults & auth ?~ basicAuth sk "" r <- liftIO $ postWith opts api [ "amount" := cents , "currency" := currency , "payment_method_types[]" := ("card" :: Text) ] - - returnJson $ object [ "clientSecret" .= (r ^? responseBody . key "client_secret")] + + returnJson $ object [ "paymentIntentId" .= (r ^? responseBody . key "id") + , "clientSecret" .= (r ^? responseBody . key "client_secret") + ] getBookPayNowR :: UserId -> Handler Html getBookPayNowR uid = do + stati <- reqGetParams <$> getRequest user <- maybeAuth pk <- appStripePk . appSettings <$> getYesod - 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 + rndr <- getUrlRenderParams + + let confirmParams = encodeToLazyText $ object $ case user of + Just (Entity _ (User _ _ _ _ _ _ _ (Just email))) -> + [ "return_url" .= rndr (BookPayCompletionR uid) stati + , "receipt_email" .= email + ] + _ -> [ "return_url" .= rndr (BookPayCompletionR uid) stati ] + + btnBack <- newIdent sectionPriceTag <- newIdent formPayment <- newIdent elementPayment <- newIdent - buttonSubmitPayment <- newIdent - buttonCancelPayment <- newIdent + btnSubmitPayment <- newIdent + btnCancelPayment <- newIdent + defaultLayout $ do setTitleI MsgCheckout addScriptRemote "https://js.stripe.com/v3/" @@ -239,33 +280,45 @@ postBookPayR uid = do oids <- filter ((== "oid") . fst) . reqGetParams <$> getRequest dates <- filter ((== "date") . fst) . reqGetParams <$> getRequest times <- filter ((== "time") . fst) . reqGetParams <$> getRequest - pms <- filter ((== "pm") . fst) . reqGetParams <$> getRequest + pms <- filter ((== "pm") . fst) . reqGetParams <$> getRequest 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 + 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) + FormSuccess (items',role',day,time,addr,tzo,tz,Entity uid' _,PayAtVenue) -> do + + bids <- forM items' $ \((_,Entity oid _),_) -> do + let book = Book uid' oid (entityKey . snd <$> role') day time addr tzo tz PayAtVenue BookStatusRequest + bid <- runDB $ insert book + now <- liftIO getCurrentTime + runDB $ insert_ $ Hist bid uid' now + (bookDay book) (bookTime book) (bookAddr book) (bookTzo book) (bookTz book) BookStatusRequest + (roleName . entityVal . snd <$> role') (staffName . entityVal . fst <$> role') + return bid + addMessageI info MsgRecordAdded + deleteSession sessKeyBooking + + redirect (BookEndR, ("bid",) . pack . show . fromSqlKey <$> bids) _ -> do msgs <- getMessages setUltDestCurrent @@ -285,21 +338,21 @@ getBookPayR uid = do oids <- filter ((== "oid") . fst) . reqGetParams <$> getRequest dates <- filter ((== "date") . fst) . reqGetParams <$> getRequest times <- filter ((== "time") . fst) . reqGetParams <$> getRequest - pms <- filter ((== "pm") . fst) . reqGetParams <$> getRequest + pms <- filter ((== "pm") . fst) . reqGetParams <$> getRequest 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 ) - + (fw,et) <- generateFormPost $ formPayMethod payMethod uid stati user ((read . unpack . snd <$>) $ LS.head dates) @@ -335,6 +388,7 @@ getBookEndR = do Just (Entity uid _) -> where_ $ x ^. BookCustomer ==. val uid where_ $ x ^. BookId `in_` valList bids return (x,o,s) + msgs <- getMessages detailsBooks <- newIdent defaultLayout $ do @@ -366,6 +420,10 @@ postBookCustomerR = do <> ((\((_,Entity oid _),_) -> ("oid",pack $ show $ fromSqlKey oid)) <$> items) <> [ ("date",pack $ show day) , ("time",pack $ show time) + , ("addr",pack $ show addr) + , ("addr",pack $ show addr) + , ("tzo",pack $ show tzo) + , ("tz",pack $ show tz) ] <> [("pm",pack $ show PayNow)] ) @@ -420,12 +478,15 @@ postBookTimeR = do Nothing Nothing business ioffers ioffers irole (maybeToList irole) msgs <- getMessages case fr of - FormSuccess (items,role,date,time,_,_,_) -> do + FormSuccess (items,role,date,time,addr,tzo,tz) -> do redirect ( BookCustomerR , maybeToList (("rid",) . (\(_,Entity rid _) -> pack $ show $ fromSqlKey rid) <$> role) <> ((\((_,Entity oid _),_) -> ("oid",pack $ show $ fromSqlKey oid)) <$> items) <> [ ("date",pack $ show date) , ("time",pack $ show time) + , ("addr",pack $ show addr) + , ("tzo",pack $ show tzo) + , ("tz",tz) ] ) _ -> defaultLayout $ do @@ -631,7 +692,7 @@ formPayMethod pm uid stati user day time business items offers role roles extra detailsServices <- newIdent return (r,$(widgetFile "book/payment/form")) where - + metodsField :: Field Handler PayMethod metodsField = Field { fieldParse = parseHelper $ \s -> case readMaybe $ unpack s of @@ -825,7 +886,7 @@ formTime day time business items offers role roles extra = do return $ if d < today then Left MsgAppointmentDayIsInThePast else Right d - + rolesField :: [(Entity Staff, Entity Role)] -> Field Handler (Entity Staff, Entity Role) rolesField options = Field @@ -861,7 +922,7 @@ formStaff items offers role roles extra = do , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing , fsAttrs = [] } (Just items) - (rolesR,rolesV) <- mopt (rolesField roles) "" (Just role) + (rolesR,rolesV) <- mopt (rolesField' roles) "" (Just role) detailsServices <- newIdent return ( (,) <$> offersR <*> rolesR @@ -869,9 +930,9 @@ formStaff items offers role roles extra = do ) where - rolesField :: [(Entity Staff, Entity Role)] - -> Field Handler (Entity Staff, Entity Role) - rolesField options = Field + rolesField' :: [(Entity Staff, Entity Role)] + -> Field Handler (Entity Staff, Entity Role) + rolesField' options = Field { fieldParse = \xs _ -> return $ case xs of (x:_) | T.null x -> Right Nothing | otherwise -> (Right . LS.head . filter (\(_, Entity rid _) -> rid == toSqlKey (read $ unpack x))) options @@ -882,7 +943,7 @@ formStaff items offers role roles extra = do $(widgetFile "book/staff/empls") , fieldEnctype = UrlEncoded } - + offersField :: Maybe Text -> [((Entity Service,Entity Offer),Maybe Html)] -> Field Handler [((Entity Service,Entity Offer),Maybe Html)] @@ -910,7 +971,7 @@ formOffers items offers extra = do x <- from $ table @Business return $ x ^. BusinessCurrency ) ) - (r,v) <- mreq (check notNull (offersField currency offers)) FieldSettings + (r,v) <- mreq (check notNull (offersField' currency offers)) FieldSettings { fsLabel = SomeMessage MsgOffer , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing , fsAttrs = [] @@ -922,9 +983,9 @@ formOffers items offers extra = do return (r,w) where - offersField :: Maybe Text -> [((Entity Service,Entity Offer),Maybe Html)] - -> Field Handler [((Entity Service,Entity Offer),Maybe Html)] - offersField currency options = Field + offersField' :: Maybe Text -> [((Entity Service,Entity Offer),Maybe Html)] + -> Field Handler [((Entity Service,Entity Offer),Maybe Html)] + offersField' currency options = Field { fieldParse = \xs _ -> return $ (Right . Just . filter (\((_, Entity oid _),_) -> oid `elem` (toSqlKey . read . unpack <$> xs))) options , fieldView = \theId name attrs vals _isReq -> do @@ -937,7 +998,7 @@ formOffers items offers extra = do $(widgetFile "book/offers/items") , fieldEnctype = UrlEncoded } - + notNull :: [a] -> Either AppMessage [a] notNull xs = case xs of @@ -1032,7 +1093,7 @@ queryOffers categs mq oids = (second (join . unValue) <$>) <$> ( select $ do unless (null oids) $ where_ $ o ^. OfferId `in_` valList oids orderBy [asc (x ^. ServiceName), asc (o ^. OfferId)] return ((x,o),t ?. ThumbnailAttribution) ) - + postBookSearchR :: Handler Html postBookSearchR = do @@ -1090,11 +1151,7 @@ getBookSearchR = do defaultLayout $ do setTitleI MsgSearch $(widgetFile "book/search/search") - - -amount :: [((Entity Service,Entity Offer),Maybe Html)] -> Centi -amount oids = sum $ (\((_,Entity _ (Offer _ _ _ price _ _ _)),_) -> price) <$> oids - + sessKeyBooking :: Text sessKeyBooking = "BOOKING_APPOINTMENT" diff --git a/src/Handler/Resources.hs b/src/Handler/Resources.hs index b150af3..d6d853e 100644 --- a/src/Handler/Resources.hs +++ b/src/Handler/Resources.hs @@ -27,12 +27,12 @@ import Foundation , AppMessage ( MsgDocumentation, MsgPhoto, MsgNavigationMenu, MsgLogin, MsgUserProfile , MsgErdDiagram, MsgBookingStateDiagram, MsgAppointmentStateDiagram - , MsgBasicEntities, MsgBusiness, MsgUser + , MsgBasicEntities, MsgBusiness, MsgUser, MsgPaymentGateway, MsgOnlineMaps , MsgAppName, MsgOverview, MsgDoc001, MsgDoc002, MsgDoc003, MsgDoc004 , MsgDoc005, MsgDoc0061, MsgDoc0062, MsgDoc0063, MsgDoc0064 , MsgDoc0065, MsgDoc0066, MsgDoc0067, MsgDoc0068 , MsgDoc007, MsgDoc008, MsgDoc009, MsgDoc010, MsgDoc011, MsgDoc012 - , MsgDoc013, MsgDoc014 + , MsgDoc013, MsgDoc014, MsgDoc015 ) ) diff --git a/static/img/Salon-ERD.svg b/static/img/Salon-ERD.svg index bdb1d6e..b13086f 100644 --- a/static/img/Salon-ERD.svg +++ b/static/img/Salon-ERD.svg @@ -621,22 +621,22 @@ >itemitem_book #{length items} _{MsgServices} - $with x <- show $ amount items + $with x <- show $ sumOf ((((folded . _1) . _2) . to entityVal) . _offerPrice) items
$maybe c <- currency #{x} diff --git a/templates/book/offers/offers.hamlet b/templates/book/offers/offers.hamlet index d06c08f..750e848 100644 --- a/templates/book/offers/offers.hamlet +++ b/templates/book/offers/offers.hamlet @@ -50,7 +50,7 @@
#{length items} _{MsgServices} - $with x <- show $ amount items + $with x <- show $ sumOf ((((folded . _1) . _2) . to entityVal) . _offerPrice) items
$maybe c <- currency #{x} diff --git a/templates/book/payment/checkout/checkout.cassius b/templates/book/payment/checkout/checkout.cassius index 6aa26b8..ca5cf71 100644 --- a/templates/book/payment/checkout/checkout.cassius +++ b/templates/book/payment/checkout/checkout.cassius @@ -17,6 +17,10 @@ main font-weight: 500 ##{formPayment} ##{elementPayment} text-align: center - ##{buttonSubmitPayment}, ##{buttonCancelPayment} + ##{btnSubmitPayment} margin-top: 2rem - width: 100% \ No newline at end of file + width: 100% + ##{btnCancelPayment} + margin-top: 1rem + width: fit-content + align-self: center \ No newline at end of file diff --git a/templates/book/payment/checkout/checkout.hamlet b/templates/book/payment/checkout/checkout.hamlet index 8d3cf0b..e41bb0b 100644 --- a/templates/book/payment/checkout/checkout.hamlet +++ b/templates/book/payment/checkout/checkout.hamlet @@ -1,15 +1,13 @@ -
- - + + arrow_back +
_{MsgCheckout} @@ -57,15 +55,15 @@ - + + _{MsgPay} - + - - _{MsgCancel} + + _{MsgCancel} diff --git a/templates/book/payment/checkout/checkout.julius b/templates/book/payment/checkout/checkout.julius index badfce8..97bc240 100644 --- a/templates/book/payment/checkout/checkout.julius +++ b/templates/book/payment/checkout/checkout.julius @@ -43,8 +43,8 @@ async function initialize() { body: JSON.stringify({ items }) }); - const { clientSecret } = await response.json(); - + const { paymentIntentId, clientSecret } = await response.json(); + const appearance = { theme: 'stripe' }; @@ -57,20 +57,30 @@ async function initialize() { const paymentElement = elements.create("payment", paymentElementOptions); paymentElement.mount("##{rawJS elementPayment}"); + + [ document.getElementById(#{btnCancelPayment}), + document.getElementById(#{btnBack}) + ].forEach(function (x) { + x.addEventListener("click",function (e) { + const r = fetch(`@{BookPaymentIntentCancelR uid}?pi=${paymentIntentId}`, { + method: "POST", + headers: { "Cotent-Type": "application/x-www-form-urlencoded" } + }).then(function (result) { + window.location.href = '@?{(BookPayR uid,(:) ("pm",pack $ show PayNow) stati)}'; + }); + }); + }); + setLoading(false); } async function handleSubmit(e) { e.preventDefault(); setLoading(true); - + const { error } = await stripe.confirmPayment({ elements, - confirmParams: { - // Make sure to change this to your payment completion page - return_url: "@{BookPayCompletionR uid}", - receipt_email: "ciukstar@yahoo.com", - }, + confirmParams: #{rawJS confirmParams} }); // This point will only be reached if there is an immediate error when @@ -133,11 +143,11 @@ function showMessage(messageText) { function setLoading(isLoading) { if (isLoading) { // Disable the button and show a spinner - document.getElementById(#{buttonSubmitPayment}).disabled = true; + document.getElementById(#{btnSubmitPayment}).disabled = true; document.querySelector("#spinner").classList.remove("hidden"); document.querySelector("#button-text").classList.add("hidden"); } else { - document.getElementById(#{buttonSubmitPayment}).disabled = false; + document.getElementById(#{btnSubmitPayment}).disabled = false; document.querySelector("#spinner").classList.add("hidden"); document.querySelector("#button-text").classList.remove("hidden"); } diff --git a/templates/book/payment/completion.cassius b/templates/book/payment/completion.cassius new file mode 100644 index 0000000..aef8aef --- /dev/null +++ b/templates/book/payment/completion.cassius @@ -0,0 +1,15 @@ + +header.mdc-top-app-bar + div.mdc-top-app-bar__row + transition: height 0.3s ease-out + +main + section.header + display: flex + flex-direction: column + align-items: center + figure + text-align: center + i.material-symbols-outlined + font-size: 4rem + color: var(--theme-success) \ No newline at end of file diff --git a/templates/book/payment/completion.hamlet b/templates/book/payment/completion.hamlet index 9170656..c12d22a 100644 --- a/templates/book/payment/completion.hamlet +++ b/templates/book/payment/completion.hamlet @@ -1,9 +1,90 @@ + + + + + + + close + + _{MsgSuccess} -

- #{pi} + + $maybe Entity uid _ <- user + + + + _{MsgPhoto} + $nothing + + + + login + -

- #{pics} + + +

+ check_circle +
+
_{MsgCongratulations}! +
_{MsgYouSuccessfullyCreatedYourBooking}. +

+ + + + _{MsgShowMyAppointments} +

+ + + + _{MsgBookNewAppointment} -

- #{rdrs} + + + + + info + + + _{MsgShowDetails} + + expand_more + + $forall (Entity bid (Book _ _ _ date time _ _ tz _ _),offer,service) <- books + $with Entity _ (Offer _ oname _ price prefix suffix _) <- offer + $with Entity _ (Service sname _ _ _ _ _) <- service + + + + + #{sname} + + #{oname}:  + $maybe x <- prefix + #{x} + $with x <- show price + $maybe c <- currency + #{x} + $nothing + #{x} + $maybe x <- suffix + #{x} + $with dt <- ((<>) ((<>) (pack $ show date) " ") (pack $ show time)) + $with dtz <- ((<>) dt ((<>) ((<>) " (" tz) ")")) + + #{dtz} + + arrow_forward_ios + + +$forall (_,msg) <- msgs + + + #{msg} + + + + + close diff --git a/templates/book/payment/completion.julius b/templates/book/payment/completion.julius new file mode 100644 index 0000000..0b45fa7 --- /dev/null +++ b/templates/book/payment/completion.julius @@ -0,0 +1,38 @@ + +window.mdc.autoInit(); + +window.onscroll = function (e) { + if (document.body.scrollTop > 128 || document.documentElement.scrollTop > 128) { + document.querySelector('header.mdc-top-app-bar').classList.remove('mdc-top-app-bar--prominent'); + document.querySelector('header.mdc-top-app-bar span.mdc-top-app-bar__title').style['white-space'] = 'nowrap'; + } else { + document.querySelector('header.mdc-top-app-bar').classList.add('mdc-top-app-bar--prominent'); + document.querySelector('header.mdc-top-app-bar span.mdc-top-app-bar__title').style['white-space'] = 'normal'; + } +}; + +Array.from( + document.querySelectorAll('span.currency[data-value][data-currency]') +).forEach(function (x) { + x.textContent = Intl.NumberFormat(navigator.language, { + style: 'currency', + currency: x.dataset.currency, + minimumFractionDigits: 0, + maximumFractionDigits: 2, + useGrouping: true + }).format(x.dataset.value); +}); + +Array.from( + document.querySelectorAll('span.currency[data-value]:not([data-currency])') +).forEach(function (x) { + x.textContent = Intl.NumberFormat(navigator.language, { + minimumFractionDigits: 0, + maximumFractionDigits: 2, + useGrouping: true + }).format(x.dataset.value); +}); + +Array.from( + document.querySelectorAll('aside.mdc-snackbar') +).forEach(function (x) { x.MDCSnackbar.open(); }); diff --git a/templates/book/payment/payment.hamlet b/templates/book/payment/payment.hamlet index 8520b58..45fcd67 100644 --- a/templates/book/payment/payment.hamlet +++ b/templates/book/payment/payment.hamlet @@ -38,8 +38,7 @@ #{amount} - rids) <> dates) <> times))}> + ^{fw} @@ -57,3 +56,13 @@ download_done _{MsgBook} + +$forall (_,msg) <- filter ((==) info . fst) msgs + + + #{msg} + + + + + close diff --git a/templates/book/search/banner.hamlet b/templates/book/search/banner.hamlet index 990ad77..ff93b4b 100644 --- a/templates/book/search/banner.hamlet +++ b/templates/book/search/banner.hamlet @@ -58,7 +58,7 @@ $if not (null offers)

#{length items} _{MsgServices} - $with x <- show $ amount items + $with x <- show $ sumOf ((((folded . _1) . _2) . to entityVal) . _offerPrice) items
$maybe c <- currency #{x} diff --git a/templates/book/search/search.hamlet b/templates/book/search/search.hamlet index 22eb962..82c8f76 100644 --- a/templates/book/search/search.hamlet +++ b/templates/book/search/search.hamlet @@ -54,7 +54,7 @@ $if not (null offers)
#{length items} _{MsgServices} - $with x <- show $ amount items + $with x <- show $ sumOf ((((folded . _1) . _2) . to entityVal) . _offerPrice) items
$maybe c <- currency #{x} diff --git a/templates/resources/docs.hamlet b/templates/resources/docs.hamlet index 97d63b1..048011a 100644 --- a/templates/resources/docs.hamlet +++ b/templates/resources/docs.hamlet @@ -71,6 +71,20 @@

_{MsgDoc013}

_{MsgDoc014} + _{MsgDoc015} +