From ca78cb164887202a9e468e4eadfc4491745cb1c8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 22 Oct 2019 05:54:55 +0200 Subject: [PATCH] Create purchase endpoint. Not linked yet to backend. --- matebeamter.cabal | 1 + src/API.hs | 4 +++ src/Control.hs | 1 + src/Control/Buy.hs | 41 ++++++++++++++++++++++++ src/Main.hs | 1 + src/Types/Orphans.hs | 23 ++++++++++++++ src/View/Buy.hs | 75 ++++++++++++++++++++++++++++++++++++++++++++ src/View/User.hs | 14 +++++++-- 8 files changed, 158 insertions(+), 2 deletions(-) create mode 100644 src/Control/Buy.hs create mode 100644 src/View/Buy.hs diff --git a/matebeamter.cabal b/matebeamter.cabal index b917d9f..2540e0b 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -32,6 +32,7 @@ executable matebeamter , Control , Control.Auth , Control.User + , Control.Buy , View , View.Scaffold , View.Auth diff --git a/src/API.hs b/src/API.hs index 26bc594..f99e09b 100644 --- a/src/API.hs +++ b/src/API.hs @@ -30,6 +30,9 @@ type UserAPI = Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine :> Get '[HTML] UserOverviewPage + :<|> "user" :> Capture "id" Int :> "buy" + :> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail] + :> Post '[HTML] UserManagePage :<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage :<|> "user" :> Capture "id" Int :> "manage" :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit @@ -60,6 +63,7 @@ type UserAPI = ( userSelectLink :<|> userOverviewLink :<|> + buyLink :<|> userManageLink :<|> userManageDetailsSubmitLink :<|> userManageAuthCreateLink :<|> diff --git a/src/Control.hs b/src/Control.hs index cc596b4..8a5ef45 100644 --- a/src/Control.hs +++ b/src/Control.hs @@ -4,3 +4,4 @@ module Control import Control.Auth as C import Control.User as C +import Control.Buy as C diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs new file mode 100644 index 0000000..b0fc4da --- /dev/null +++ b/src/Control/Buy.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Control.Buy where + +import Servant +import Servant.Client +import Servant.Client.Core.Auth (mkAuthenticatedRequest) + +import qualified Data.Text as T + +import Data.Text.I18n + +import Data.String (fromString) + +import Control.Monad.Reader (ask) +import Control.Monad.IO.Class (liftIO) + +-- imports from "mateamt" + +import qualified "mateamt" Types as MT + +-- internal imports + +import Types +import View +import Util +import Client +import ClientAuth +import API + +buyControl + :: Maybe T.Text + -> Int + -> [MT.PurchaseDetail] + -> UserHandler UserManagePage +buyControl mcookie uid pds = throwError $ err500 + { errBody = fromString (show pds) + } diff --git a/src/Main.hs b/src/Main.hs index 6973a24..ab832be 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -43,6 +43,7 @@ userApp initState = serveWithContext userApi EmptyContext $ (`runReaderT` initState) (\mcookie -> userSelectControl mcookie :<|> userOverviewControl mcookie + :<|> buyControl mcookie :<|> userManageControl mcookie :<|> userManageDetailsSubmitControl mcookie :<|> userManageAuthCreateControl mcookie diff --git a/src/Types/Orphans.hs b/src/Types/Orphans.hs index 2df05fd..ad35bdf 100644 --- a/src/Types/Orphans.hs +++ b/src/Types/Orphans.hs @@ -2,6 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} module Types.Orphans where @@ -11,8 +13,29 @@ import Servant.API import Servant.HTML.Blaze import Web.Internal.FormUrlEncoded +import qualified Data.Text as T +import Data.Maybe (fromJust) + instance MimeUnrender HTML MT.UserSubmit instance FromForm MT.UserSubmit instance MimeUnrender HTML MT.UserDetailsSubmit instance FromForm MT.UserDetailsSubmit + +instance MimeUnrender HTML [MT.PurchaseDetail] +instance FromForm [MT.PurchaseDetail] where + fromForm form = + let kvs = toListStable form + ks = fst (unzip kvs) + kpids = filter ("productSelect" `T.isPrefixOf`) ks + prods = filter ((`notElem` kpids) . fst) kvs + stripPid = snd . T.breakOnEnd "-" + digestForm key = + let pid = read (T.unpack $ stripPid key) + amount = read + (T.unpack . fromJust $ + lookup ("productAmount-" <> stripPid key) prods) + in MT.PurchaseDetail pid amount + res = map digestForm kpids + in + Right res diff --git a/src/View/Buy.hs b/src/View/Buy.hs new file mode 100644 index 0000000..7614b63 --- /dev/null +++ b/src/View/Buy.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} +module View.Buy where + +import Servant.Links + +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as HA + +import qualified Data.Text as T + +import Data.String (fromString) + +import Data.Text.I18n + +import Data.Maybe (isJust, fromJust) + +-- imports from mateamt + +import qualified "mateamt" Types as MT + +-- internal imports + +import Util +import Types +import View.Scaffold +import API + +buyProductsForm + :: L10n + -> Locale + -> [MT.ProductShortOverview] + -> H.Html +buyProductsForm l10n locale prods = do + mapM_ (\(MT.ProductShortOverview pid ident price amount ml maid) -> + H.div $ do + H.div + H.! HA.class_ "form-group optional" + H.!? + ( isJust maid + , productBgStyle (fromString $ show $ fromJust maid) + ) + $ do + H.label + H.! HA.for ("product-select-" <> fromString (show pid)) $ + H.toHtml ident + H.input + H.! HA.id ("product-select-" <> fromString (show pid)) + H.! HA.class_ "form-control product-select" + H.! HA.name ("productSelect-" <> fromString (show pid)) + H.! HA.type_ "checkbox" + H.! HA.value "true" + H.div + H.! HA.class_ "form-group optional" + $ do + H.label + H.! HA.for ("product-amount-" <> fromString (show pid)) $ + H.toHtml (translate "Amount") + H.input + H.! HA.id ("product-amount-" <> fromString (show pid)) + H.! HA.class_ "form-control product-amount" + H.! HA.name ("productAmount-" <> fromString (show pid)) + H.! HA.type_ "number" + H.! HA.min "0" + H.! HA.step "1" + H.! HA.value "1" + ) + prods + H.div H.! HA.class_ "form-group optional" $ + H.button + H.! HA.class_ "btn btn-default" + H.! HA.type_ "submit" + $ H.toHtml $ translate "Buy" + where + translate = localize l10n locale . gettext diff --git a/src/View/User.hs b/src/View/User.hs index 98bf418..b62db93 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -80,10 +80,20 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $ MT.PrimaryPass -> userSettingsPointer l10n locale (MT.userDetailsId ud) MT.SecondaryPass -> - buyProductsForm l10n locale pos + H.form + H.! HA.method "post" + H.! HA.action ("/" <> (fromString $ show $ linkURI $ + buyLink (MT.userDetailsId ud))) + H.! HA.enctype "application/x-www-form-urlencoded" $ + buyProductsForm l10n locale pos MT.ChallengeResponse -> do userSettingsPointer l10n locale (MT.userDetailsId ud) - buyProductsForm l10n locale pos + H.form + H.! HA.method "post" + H.! HA.action ("/" <> (fromString $ show $ linkURI $ + buyLink (MT.userDetailsId ud))) + H.! HA.enctype "application/x-www-form-urlencoded" $ + buyProductsForm l10n locale pos where translate = localize l10n locale . gettext