From cb8e927eaedb1ed1bf29db3a309bbde5a72a4e52 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 13 Oct 2019 22:25:05 +0200 Subject: [PATCH] starting product pages --- src/API.hs | 3 +++ src/Control.hs | 1 + src/Control/Auth.hs | 5 ++++- src/Control/Product.hs | 49 ++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 1 + src/Types/Views.hs | 2 ++ src/View.hs | 1 + src/View/Product.hs | 45 ++++++++++++++++++++++++++++++++++++++ 8 files changed, 106 insertions(+), 1 deletion(-) create mode 100644 src/Control/Product.hs create mode 100644 src/View/Product.hs diff --git a/src/API.hs b/src/API.hs index 83965fb..d248c35 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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) diff --git a/src/Control.hs b/src/Control.hs index cc596b4..16138c8 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.Product as C diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 70ee276..0d65179 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -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") diff --git a/src/Control/Product.hs b/src/Control/Product.hs new file mode 100644 index 0000000..3822193 --- /dev/null +++ b/src/Control/Product.hs @@ -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 + } diff --git a/src/Main.hs b/src/Main.hs index e9ee339..5b38b30 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -47,6 +47,7 @@ userApp initState = serveWithContext userApi (EmptyContext) $ :<|> userOverviewControl mcookie :<|> userNewControl mcookie :<|> userNewPostControl mcookie + :<|> productListControl mcookie :<|> authControl mcookie :<|> authPostControl mcookie ) diff --git a/src/Types/Views.hs b/src/Types/Views.hs index 2cbe87f..18dc301 100644 --- a/src/Types/Views.hs +++ b/src/Types/Views.hs @@ -8,4 +8,6 @@ type UserNewPage = H.Html type UserOverviewPage = H.Html +type ProductListPage = H.Html + type AuthPage = H.Html diff --git a/src/View.hs b/src/View.hs index c2782ae..c09ba74 100644 --- a/src/View.hs +++ b/src/View.hs @@ -4,3 +4,4 @@ module View import View.Auth as V import View.User as V +import View.Product as V diff --git a/src/View/Product.hs b/src/View/Product.hs new file mode 100644 index 0000000..bdc31db --- /dev/null +++ b/src/View/Product.hs @@ -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