{-# 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] -> Maybe Bool -> UserHandler BuyConfirmPage buyControl mcookie uid pds forceBuy = if not (null pds) then 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) ) total = foldl (\acc ( MT.PurchaseDetail _ amount , MT.ProductShortOverview _ _ price _ _ _) -> acc + (max 0 amount) * price ) 0 ziptup return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie) else throwError (redirect303 $ userOverviewLink uid Nothing) cashBuyOverviewControl :: Maybe T.Text -> Maybe MT.ProductRefine -> UserHandler CashBuyOverviewPage cashBuyOverviewControl mcookie mrefine = do (ReadState l10n backend _) <- ask let loc = localeFromCookie mcookie eproducts <- liftIO $ runClientM (productShortList mrefine ) backend case eproducts of Right prods -> return $ cashBuyOverviewPage l10n loc mcookie prods purchaseControl :: Maybe T.Text -> Int -> [MT.PurchaseDetail] -> Maybe 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 (isJust forceBuy && fromJust 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 () 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 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 (Just True)) (MT.PurchaseResult _ miss) -> throwError $ addMessage (translate l10n loc "Purchase partly successful.") $ redirect307 (buyLink uid (Just 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 translate l10n locale = localize l10n locale . gettext