starting product pages

This commit is contained in:
nek0 2019-10-13 22:25:05 +02:00
parent df11ebcc0a
commit cb8e927eae
8 changed files with 106 additions and 1 deletions

View File

@ -35,6 +35,8 @@ type UserAPI =
:<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> Post '[HTML] UserSelectPage
:<|> "product" :> "list" :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] ProductListPage
:<|> "auth"
:> Get '[HTML]
(Headers
@ -51,6 +53,7 @@ type UserAPI =
userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
productListLink :<|>
authLink :<|>
authPostLink
) = allLinks (Proxy :: Proxy UserAPI)

View File

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

View File

@ -125,7 +125,10 @@ authPostControl (Just cookies) (AuthReturn pass method) = do
backend
case etoken of
Right (MT.Granted (MT.AuthToken token)) -> do
let headers = errHeaders $ redirect303 userSelectLink -- FIXME: redirect to product select
let headers = errHeaders $
redirect303
-- FIXME: redirect to product select
(productListLink (Just MT.AvailableProducts))
throwError $ err303
{ errHeaders = headers ++
[ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")

49
src/Control/Product.hs Normal file
View File

@ -0,0 +1,49 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-}
module Control.Product where
import Servant
import Servant.Client
import Servant.Server
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
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 View
import Types
import Client
import Util
productListControl
:: Maybe T.Text
-> Maybe MT.ProductRefine
-> UserHandler ProductListPage
productListControl mcookie mrefine = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
eProducts <- liftIO $ runClientM
(productShortList mrefine)
backend
case eProducts of
Right products ->
return $ productListPage l10n loc mrefine products
Left err ->
throwError $ err500
{ errBody = fromString $ show err
}

View File

@ -47,6 +47,7 @@ userApp initState = serveWithContext userApi (EmptyContext) $
:<|> userOverviewControl mcookie
:<|> userNewControl mcookie
:<|> userNewPostControl mcookie
:<|> productListControl mcookie
:<|> authControl mcookie
:<|> authPostControl mcookie
)

View File

@ -8,4 +8,6 @@ type UserNewPage = H.Html
type UserOverviewPage = H.Html
type ProductListPage = H.Html
type AuthPage = H.Html

View File

@ -4,3 +4,4 @@ module View
import View.Auth as V
import View.User as V
import View.Product as V

45
src/View/Product.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module View.Product where
import Servant.Links
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Data.Text.I18n
import Data.String (fromString)
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import Util
import Types
import View.Scaffold
import API
productListPage
:: L10n
-> Locale
-> Maybe MT.ProductRefine
-> [MT.ProductShortOverview]
-> ProductListPage
productListPage l10n locale mRefine psos = scaffold l10n locale (initPage $
(translate "Matebeamter") <>
" - " <>
(translate "Product list")
) $ if null psos
then
H.h1 $ H.toHtml $ translate "No products present"
else do
mapM_ (\(MT.ProductShortOverview pid ident price amount ml mAvatar) -> do
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $
productListLink mRefine)) $
H.toHtml ident
) psos
where
translate = localize l10n locale . gettext