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.Auth
, Control.User
, Control.Buy
, View
, View.Scaffold
, View.Auth

View file

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

View file

@ -4,3 +4,4 @@ module Control
import Control.Auth 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)
(\mcookie -> userSelectControl mcookie
:<|> userOverviewControl mcookie
:<|> buyControl mcookie
:<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie

View file

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

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