matebeamter/src/Control/Buy.hs

181 lines
5.2 KiB
Haskell

{-# 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