matebeamter/src/Control/Buy.hs

289 lines
8.6 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]
-> 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