{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} module Control.User where import Servant import Servant.Client import Servant.Client.Core.Auth import Data.String (fromString) import qualified Data.Text as T import Data.Text.I18n import Data.Maybe (fromMaybe, isJust) import Data.Either.Combinators (leftToMaybe) import Control.Monad (void) import Control.Monad.Reader (ask, asks) import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status -- imports from "mateamt" import qualified "mateamt" Types as MT -- internal imports import Types import Client import ClientAuth import View import Hash import API import Util userSelectControl :: Maybe T.Text -> Maybe MT.UserRefine -> UserHandler UserSelectPage userSelectControl mcookie mrefine = do (ReadState l10n backend _ symbol version) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) euser <- liftIO $ runClientM (userList mrefine) backend case euser of Right uss -> return $ userSelectPage l10n loc uss version mcookie Left err -> error $ show err userNewControl :: Maybe T.Text -> UserHandler UserNewPage userNewControl mcookie = do (ReadState l10n _ _ symbol version) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) return $ userNewPage l10n loc version mcookie userNewPostControl :: Maybe T.Text -> MT.UserSubmit -> UserHandler UserSelectPage userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do backend <- asks rsBackend hashedPass <- hashPassword pass void $ liftIO $ runClientM (userNew $us { MT.userSubmitPassHash = hashedPass }) backend throwError $ redirect303 (userSelectLink Nothing) userOverviewControl :: Maybe T.Text -> Int -> Maybe MT.ProductRefine -> UserHandler UserOverviewPage userOverviewControl mcookie uid mRefine = do (ReadState l10n backend _ symbol version) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie (token, mAuthUser) = parseTokenAndUser mcookie mMethod = T.unpack <$> (lookup "x-method" =<< mParsedCookie) getProducts = liftIO $ runClientM (productShortList mRefine) backend euser <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend eproducts <- case fmap (toEnum . read) mMethod of Just MT.PrimaryPass -> return (Right []) Just MT.SecondaryPass -> getProducts Just MT.ChallengeResponse -> getProducts _ -> return (Right []) case (euser, eproducts) of (Right ud, Right prods) -> case mMethod of Just method -> if mAuthUser == Just uid then return $ userOverviewPage l10n loc (toEnum $ read method) ud prods version mcookie symbol else redirectOverAuth (Just uid) (Just $ userOverviewLink uid mRefine) mRefine Nothing -> redirectOverAuth mAuthUser Nothing mRefine (Left uerr, Right _) -> case uerr of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 401 then redirectOverAuth (Just uid) Nothing mRefine else throwError $ err500 { errBody = fromString (show uerr) } _ -> throwError $ err500 { errBody = fromString (show uerr) } (Right _, Left perr) -> throwError $ err500 { errBody = fromString (show perr) } (Left uerr, Left perr) -> throwError $ err500 { errBody = fromString (show uerr) <> " " <> fromString (show perr) } userRechargeControl :: Maybe T.Text -> Int -> UserHandler UserRechargePage userRechargeControl mcookie uid = do l10n <- asks rsL10n (ReadState l10n backend _ symbol version) <- ask let loc = localeFromCookie mcookie return $ userRechargePage l10n loc version mcookie uid symbol userPostRechargeControl :: Maybe T.Text -> Int -> UserRecharge -> UserHandler UserOverviewPage userPostRechargeControl mcookie uid (UserRecharge amount) = do (ReadState l10n backend _ _ _) <- ask let loc = localeFromCookie mcookie (token, mauthuser) = parseTokenAndUser mcookie eresult <- liftIO $ runClientM (userRecharge (mkAuthenticatedRequest token authenticateReq) (MT.UserRecharge $ floor $ amount * 100) ) backend if isJust mauthuser then case eresult of Right _ -> throwError $ addMessage (translate l10n loc "Recharge Successful") $ redirect303 (userOverviewLink uid Nothing) Left err -> throwError $ addMessage (translate l10n loc ("An error occured. " <> fromString (show err))) $ redirect303 (userRechargeLink uid) else redirectOverAuth (Just uid) (Just (userRechargeLink uid)) Nothing where translate l10n locale = localize l10n locale . gettext userManageControl :: Maybe T.Text -> Int -> UserHandler UserManagePage userManageControl mcookie uid = do (ReadState l10n backend _ symbol version) <- ask let loc = localeFromCookie mcookie (token, mAuthUser) = parseTokenAndUser mcookie eUserDetails <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend eAuthOverviews <- liftIO $ runClientM (authManageList (mkAuthenticatedRequest token authenticateReq)) backend case (eUserDetails, eAuthOverviews) of (Right userDetails, Right authOverviews) -> if Just uid == mAuthUser then return $ userManagePage l10n loc userDetails authOverviews version mcookie else redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing err -> handleErrors (Just uid) (Just $ userManageLink uid) [leftToMaybe (fst err), leftToMaybe (snd err)] userManageDetailsSubmitControl :: Maybe T.Text -> Int -> MT.UserDetailsSubmit -> UserHandler UserOverviewPage userManageDetailsSubmitControl mcookie uid uds = do (ReadState _ backend _ _ _) <- ask let (token, mAuthUser) = parseTokenAndUser mcookie eReturn <- liftIO $ runClientM (userUpdate (mkAuthenticatedRequest token authenticateReq) uds) backend case eReturn of Right _ -> throwError $ redirect303 (userManageLink uid) Left err -> handleErrors mAuthUser (Just $ userManageLink uid) [Just err] userManageAuthCreateControl :: Maybe T.Text -> Int -> AuthSubmitReturn -> UserHandler UserOverviewPage userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do (ReadState _ backend _ _ _) <- ask let (token, mAuthUser) = parseTokenAndUser mcookie hashedPass <- hashPassword pass eReturn <- liftIO $ runClientM (authManageNewAuth (mkAuthenticatedRequest token authenticateReq) (MT.AuthSubmit (toEnum method) comment hashedPass) ) backend case eReturn of Right _ -> throwError $ redirect303 $ userManageLink uid Left err -> handleErrors mAuthUser (Just $ userManageLink uid) [Just err] userManageAuthDeleteControl :: Maybe T.Text -> Int -> AuthDetailId -> UserHandler UserOverviewPage userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do backend <- asks rsBackend let (token, mAuthUser) = parseTokenAndUser mcookie eReturn <- liftIO $ runClientM (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) backend case eReturn of Right _ -> throwError $ redirect303 $ userManageLink uid Left err -> case err of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 406 then throwError (redirect303 $ userManageLink uid) else handleErrors mAuthUser Nothing [Just err] _ -> handleErrors mAuthUser (Just $ userSelectLink Nothing) [Just err]