matebeamter/src/Control/Buy.hs

138 lines
3.9 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)
import Data.List (sortOn)
import Control.Monad (void)
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]
-> UserHandler BuyConfirmPage
buyControl mcookie uid pds =
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)
else
throwError (redirect303 $ userOverviewLink uid Nothing)
purchaseControl
:: Maybe T.Text
-> Int
-> [MT.PurchaseDetail]
-> UserHandler UserSelectPage
purchaseControl mcookie uid pds =
if not (null pds)
then do
backend <- asks rsBackend
let (token, _) = parseTokenAndUser mcookie
eresult <- liftIO $ runClientM
(buy
(mkAuthenticatedRequest token authenticateReq)
pds
)
backend
case eresult of
Right result -> case result of
(MT.PurchaseResult MT.PurchaseOK []) ->
logoutAndRedirectHome backend token
(MT.PurchaseResult MT.PurchaseDebtful []) ->
logoutAndRedirectHome backend token
(MT.PurchaseResult (MT.PayAmount price) []) ->
throwError $ err500
{ errBody =
"No messaging system implemented. "
<> "Purchase was processed, though. "
<> "Please pay " <> (fromString $ T.unpack $ formatMoney price)
<> " in cash."
}
(MT.PurchaseResult (MT.PayAmount price) miss) ->
throwError $ err500
{ errBody =
"No messaging system implemented. "
<> "Purchase was processed, though. "
<> "Please pay " <> (fromString $ T.unpack $ formatMoney price)
<> " in cash. "
<> "Stock is lacking following items: "
<> fromString (show miss)
}
(MT.PurchaseResult _ miss) ->
throwError $ err500
{ errBody =
"No messaging system implemented. "
<> "Purchase was processed, though. "
<> "Stock is lacking following items: "
<> fromString (show miss)
}
Left err ->
throwError $ err500
{ errBody = fromString (show err)
}
else
throwError (redirect303 $ userOverviewLink uid Nothing)
where
logoutAndRedirectHome backend token = do
void $ liftIO $ runClientM
(authLogout
(mkAuthenticatedRequest token authenticateReq)
)
backend
throwError $ redirect303 userSelectLink