Create purchase endpoint. Not linked yet to backend.

matebeamter.cabal

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

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

src/Control.hs

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

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

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

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

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

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