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