{-# 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 Data.Maybe (fromMaybe, fromJust, isJust) import Data.List (sortOn) import Control.Monad (void, when) import Control.Monad.Reader (ask, asks) 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] -> Bool -> UserHandler BuyConfirmPage buyControl mcookie uid pds forceBuy = do (ReadState l10n backend _ symbol version) <- ask let (token, _) = parseTokenAndUser mcookie loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) if not (null pds) then do let 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) ) total = foldl (\acc ( MT.PurchaseDetail _ amount , MT.ProductShortOverview _ _ price _ _ _) -> acc + max 0 amount * price ) 0 ziptup return (buyConfirmPage l10n loc uid ziptup total forceBuy version mcookie symbol ) Left err -> throwError $ addMessage (fromString $ show err) $ redirect303 (userSelectLink Nothing) else throwError ( addMessage (translate l10n loc "Please select items for purchase") $ redirect303 (userOverviewLink uid Nothing) ) where translate l10n locale = localize l10n locale . gettext purchaseControl :: Maybe T.Text -> Int -> [MT.PurchaseDetail] -> Bool -> UserHandler UserSelectPage purchaseControl mcookie uid pds forceBuy = do l10n <- asks rsL10n let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) if not (null pds) then do backend <- asks rsBackend let (token, _) = parseTokenAndUser mcookie erefres <- if forceBuy then do let refills = map (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount 0) pds liftIO $ runClientM (productStockRefill (mkAuthenticatedRequest token authenticateReq) refills ) backend else return $ Right () case erefres of Right _ -> return () Left err -> throwError $ addMessage (fromString $ show err) $ redirect303 (userOverviewLink uid Nothing) eresult <- liftIO $ runClientM (buy (mkAuthenticatedRequest token authenticateReq) pds ) backend case eresult of Right result -> case result of (MT.PurchaseResult MT.PurchaseOK []) -> logoutAndRedirectHome (translate l10n loc "Purchase successful") backend token (MT.PurchaseResult MT.PurchaseDebtful []) -> logoutAndRedirectHome (translate l10n loc "Purchase successful") backend token (MT.PurchaseResult (MT.PayAmount _) _) -> throwError $ err500 { errBody = "You can't buy with cash while logged in" } -- (MT.PurchaseResult (MT.PayAmount price) []) -> -- logoutAndRedirectHome -- (translate l10n loc "Please Pay" <> ": " <> formatMoney price) -- backend -- token -- (MT.PurchaseResult (MT.PayAmount price) miss) -> -- throwError -- $ addMessage (translate l10n loc "Please Pay" <> ": " -- <> formatMoney price -- <> "\n" -- <> translate l10n loc ("But there seems to be something missing:") -- ) -- $ redirect307 (buyLink uid True) (MT.PurchaseResult _ miss) -> throwError $ addMessage (translate l10n loc "Purchase partly successful.") $ redirect307 (buyLink uid True) Left err -> throwError $ addMessage (fromString (show err)) $ redirect303 (userOverviewLink uid Nothing) else throwError $ addMessage (translate l10n loc "Please choose your product(s)") (redirect303 $ userOverviewLink uid Nothing) where logoutAndRedirectHome message backend token = do void $ liftIO $ runClientM (authLogout (mkAuthenticatedRequest token authenticateReq) ) backend throwError $ addMessage message $ redirect303 (userSelectLink Nothing) translate l10n locale = localize l10n locale . gettext cashBuyOverviewControl :: Maybe T.Text -> Maybe MT.ProductRefine -> UserHandler CashBuyOverviewPage cashBuyOverviewControl mcookie mrefine = do (ReadState l10n backend _ symbol version) <- ask let loc = localeFromCookie mcookie eproducts <- liftIO $ runClientM (productShortList mrefine ) backend case eproducts of Right prods -> return $ cashBuyOverviewPage l10n loc version mcookie prods Left err -> throwError $ err500 { errBody = fromString (show err) } cashBuyPurchaseControl :: Maybe T.Text -- -> Bool -> [MT.PurchaseDetail] -> UserHandler UserSelectPage cashBuyPurchaseControl mcookie {-forceBuy-} pds = do l10n <- asks rsL10n symbol <- asks rsCurrencySymbol let loc = localeFromCookie mcookie if not (null pds) then do backend <- asks rsBackend -- erefres <- if forceBuy -- then do -- let refills = map -- (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount) -- pds -- liftIO $ runClientM -- (productStockRefill -- (mkAuthenticatedRequest token authenticateReq) -- refills -- ) -- backend -- else -- return $ Right () eresult <- liftIO $ runClientM (buy (mkAuthenticatedRequest "secret" nonAuthenticateRequest) pds ) backend case eresult of Right result -> case result of (MT.PurchaseResult (MT.PayAmount price) []) -> throwError $ addMessage (translate l10n loc "Please Pay" <> ": " <> formatMoney price <> symbol) $ redirect303 (userSelectLink Nothing) (MT.PurchaseResult (MT.PayAmount price) miss) -> do eproducts <- liftIO $ runClientM (productShortList (Just MT.AllProducts) ) backend let missIds = map (\(MT.PurchaseDetail pid amount) -> (pid, amount)) miss case eproducts of Right prods -> throwError $ addMessage (translate l10n loc "Please Pay" <> ": " <> formatMoney price <> symbol <> ". " <> translate l10n loc "But there seems to be something missing: " <> mconcat (reverse $ foldl (\acc (MT.ProductShortOverview psoid ident _ _ _ _) -> if psoid `elem` map fst missIds then (fromString (show $ fromJust $ lookup psoid missIds) <> " x " <> fromString (T.unpack ident)) : acc else acc ) [] prods )) $ redirect303 (userSelectLink Nothing) Left err -> throwError $ err500 { errBody = fromString (show err) } Left err -> handleClientErr err Nothing (Just (userSelectLink Nothing)) else throwError $ addMessage (translate l10n loc "Please choose your product(s)") (redirect303 $ cashBuyLink Nothing) where translate l10n locale = localize l10n locale . gettext