starting product pages

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)

src/Control.hs

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

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

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

src/Main.hs

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

src/Types/Views.hs

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

src/View.hs

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

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