Create purchase endpoint. Not linked yet to backend.

This commit is contained in:
nek0 2019-10-22 05:54:55 +02:00
parent 6ba45b564e
commit ca78cb1648
8 changed files with 158 additions and 2 deletions

View file

@ -32,6 +32,7 @@ executable matebeamter
, Control , Control
, Control.Auth , Control.Auth
, Control.User , Control.User
, Control.Buy
, View , View
, View.Scaffold , View.Scaffold
, View.Auth , View.Auth

View file

@ -30,6 +30,9 @@ type UserAPI =
Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] UserOverviewPage :> 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" :> Get '[HTML] UserManagePage
:<|> "user" :> Capture "id" Int :> "manage" :<|> "user" :> Capture "id" Int :> "manage"
:> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
@ -60,6 +63,7 @@ type UserAPI =
( userSelectLink :<|> ( userSelectLink :<|>
userOverviewLink :<|> userOverviewLink :<|>
buyLink :<|>
userManageLink :<|> userManageLink :<|>
userManageDetailsSubmitLink :<|> userManageDetailsSubmitLink :<|>
userManageAuthCreateLink :<|> userManageAuthCreateLink :<|>

View file

@ -4,3 +4,4 @@ module Control
import Control.Auth as C import Control.Auth as C
import Control.User as C import Control.User as C
import Control.Buy as C

41
src/Control/Buy.hs Normal file
View file

@ -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)
}

View file

@ -43,6 +43,7 @@ userApp initState = serveWithContext userApi EmptyContext $
(`runReaderT` initState) (`runReaderT` initState)
(\mcookie -> userSelectControl mcookie (\mcookie -> userSelectControl mcookie
:<|> userOverviewControl mcookie :<|> userOverviewControl mcookie
:<|> buyControl mcookie
:<|> userManageControl mcookie :<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie :<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie :<|> userManageAuthCreateControl mcookie

View file

@ -2,6 +2,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Types.Orphans where module Types.Orphans where
@ -11,8 +13,29 @@ import Servant.API
import Servant.HTML.Blaze import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded import Web.Internal.FormUrlEncoded
import qualified Data.Text as T
import Data.Maybe (fromJust)
instance MimeUnrender HTML MT.UserSubmit instance MimeUnrender HTML MT.UserSubmit
instance FromForm MT.UserSubmit instance FromForm MT.UserSubmit
instance MimeUnrender HTML MT.UserDetailsSubmit instance MimeUnrender HTML MT.UserDetailsSubmit
instance FromForm 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

75
src/View/Buy.hs Normal file
View file

@ -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

View file

@ -80,10 +80,20 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
MT.PrimaryPass -> MT.PrimaryPass ->
userSettingsPointer l10n locale (MT.userDetailsId ud) userSettingsPointer l10n locale (MT.userDetailsId ud)
MT.SecondaryPass -> 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 MT.ChallengeResponse -> do
userSettingsPointer l10n locale (MT.userDetailsId ud) 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 where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext