289 lines
8.6 KiB
Haskell
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
|