From 05a4acd1ddcc4482bc8c2afd9423bb00e95e4f65 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 22 Oct 2019 20:43:50 +0200 Subject: [PATCH] meow! --- src/Control/Buy.hs | 26 ++++++++++++++++++++++---- src/Control/User.hs | 12 ------------ src/Types/Views.hs | 2 ++ src/Util.hs | 16 +++++++++++++++- src/View.hs | 1 + src/View/Buy.hs | 35 +++++++++++++++++++++++++++++++++++ 6 files changed, 75 insertions(+), 17 deletions(-) diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index b0fc4da..5198347 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -15,6 +15,10 @@ import Data.Text.I18n import Data.String (fromString) +import Data.Maybe (fromMaybe) + +import Data.List (sortOn) + import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO) @@ -35,7 +39,21 @@ buyControl :: Maybe T.Text -> Int -> [MT.PurchaseDetail] - -> UserHandler UserManagePage -buyControl mcookie uid pds = throwError $ err500 - { errBody = fromString (show pds) - } + -> UserHandler BuyConfirmPage +buyControl mcookie uid pds = do + (ReadState l10n backend _) <- ask + let (token, _) = parseTokenAndUser mcookie + loc = Locale + (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) + pids = map MT.purchaseDetailProduct pds + epsovs <- liftIO $ runClientM + (productShortList (Just MT.AllProducts)) + backend + case epsovs of + Right psovs -> do + let currentPsovs = filter ((`elem` pids) . MT.productShortOverviewId) psovs + ziptup = sortOn (MT.productShortOverviewIdent . snd) (zip + (sortOn MT.purchaseDetailProduct pds) + (sortOn MT.productShortOverviewId currentPsovs) + ) + return (buyConfirmPage l10n loc ziptup) diff --git a/src/Control/User.hs b/src/Control/User.hs index 7b1e223..862a158 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -36,18 +36,6 @@ import Hash import API import Util -parseTokenAndUser - :: Maybe T.Text - -> (String, Maybe String) -parseTokenAndUser mcookie = - (token, mAuthUser) - where - token = T.unpack $ fromMaybe "secret" - (lookup "x-token" =<< mParsedCookie) - mAuthUser = T.unpack <$> - (lookup "x-auth-user" =<< mParsedCookie) - mParsedCookie = fmap parseCookieText mcookie - userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage userSelectControl mcookie = do (ReadState l10n backend _) <- ask diff --git a/src/Types/Views.hs b/src/Types/Views.hs index 0482839..8df87c3 100644 --- a/src/Types/Views.hs +++ b/src/Types/Views.hs @@ -13,3 +13,5 @@ type UserManagePage = H.Html type ProductListPage = H.Html type AuthPage = H.Html + +type BuyConfirmPage = H.Html diff --git a/src/Util.hs b/src/Util.hs index 405e362..48bc32c 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -22,6 +22,8 @@ import Data.List.Split (chunksOf) import Data.String (fromString) +import Data.Maybe (fromMaybe) + import Web.Cookie import Text.Printf (printf) @@ -52,7 +54,7 @@ formatMoney amount = pre <> t <> "," <> c t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp) c = fromString $ snd sp sp = tail <$> - break (== '.') (printf "%.2f" (fromIntegral $ abs amount :: Float)) + break (== '.') (printf "%.2f" (abs $ (fromIntegral amount / 100) :: Float)) redirect303 :: Link @@ -71,6 +73,18 @@ parseCookieText = map (\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two)) . T.splitOn "; " +parseTokenAndUser + :: Maybe T.Text + -> (String, Maybe String) +parseTokenAndUser mcookie = + (token, mAuthUser) + where + token = T.unpack $ fromMaybe "secret" + (lookup "x-token" =<< mParsedCookie) + mAuthUser = T.unpack <$> + (lookup "x-auth-user" =<< mParsedCookie) + mParsedCookie = fmap parseCookieText mcookie + handleErrors :: (Traversable t, Show (t (Maybe ClientError))) => Maybe Int diff --git a/src/View.hs b/src/View.hs index c2782ae..7b55893 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.Buy as V diff --git a/src/View/Buy.hs b/src/View/Buy.hs index 7614b63..115d01f 100644 --- a/src/View/Buy.hs +++ b/src/View/Buy.hs @@ -26,6 +26,41 @@ import Types import View.Scaffold import API +buyConfirmPage + :: L10n + -> Locale + -> [(MT.PurchaseDetail, MT.ProductShortOverview)] + -> H.Html +buyConfirmPage l10n locale ziptups = scaffold l10n locale (initPage $ + translate "Matebeamter" <> + " - " <> + translate "Home" + ) $ do + H.p $ H.toHtml $ translate "You are about to buy the following items:" + H.ul $ + mapM_ + (\( MT.PurchaseDetail pdid amount + , MT.ProductShortOverview pid ident price _ _ mava) -> + H.li $ do + H.img + H.!? + ( isJust mava + , HA.src (fromString $ show $ fromJust mava) -- TODO: ask for avatar + ) + H.toHtml + (fromString (show amount) + <> " " + <> ident + <> " @ " + <> formatMoney price + <> " " + -- <> "€" -- TODO: ask for currency symbol + ) + ) + ziptups + where + translate = localize l10n locale . gettext + buyProductsForm :: L10n -> Locale