2019-09-08 10:48:57 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE PackageImports #-}
|
2019-10-04 07:04:23 +00:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
2019-10-14 13:07:17 +00:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2019-09-08 10:48:57 +00:00
|
|
|
module Control.User where
|
|
|
|
|
2019-09-17 19:29:56 +00:00
|
|
|
import Servant
|
2019-09-08 10:48:57 +00:00
|
|
|
import Servant.Client
|
2019-09-18 13:24:23 +00:00
|
|
|
import Servant.Client.Core.Auth
|
2019-09-17 19:29:56 +00:00
|
|
|
|
|
|
|
import Data.String (fromString)
|
2019-09-08 10:48:57 +00:00
|
|
|
|
2019-10-04 07:04:23 +00:00
|
|
|
import qualified Data.Text as T
|
2019-09-08 15:27:38 +00:00
|
|
|
import Data.Text.I18n
|
|
|
|
|
2019-11-01 11:22:28 +00:00
|
|
|
import Data.Maybe (fromMaybe, isJust)
|
2019-10-14 13:07:17 +00:00
|
|
|
import Data.Either.Combinators (leftToMaybe)
|
2019-10-04 07:04:23 +00:00
|
|
|
|
2019-10-16 16:07:12 +00:00
|
|
|
import Control.Monad (void)
|
|
|
|
import Control.Monad.Reader (ask, asks)
|
2019-09-08 10:48:57 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
2019-09-18 13:24:23 +00:00
|
|
|
import Network.HTTP.Types.Status
|
|
|
|
|
2019-09-17 19:29:56 +00:00
|
|
|
-- imports from "mateamt"
|
|
|
|
|
|
|
|
import qualified "mateamt" Types as MT
|
2019-09-08 10:48:57 +00:00
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
|
|
|
import Client
|
2019-09-18 13:24:23 +00:00
|
|
|
import ClientAuth
|
2019-09-08 10:48:57 +00:00
|
|
|
import View
|
2019-09-17 19:29:56 +00:00
|
|
|
import Hash
|
|
|
|
import API
|
2019-09-18 13:24:23 +00:00
|
|
|
import Util
|
2019-09-08 10:48:57 +00:00
|
|
|
|
2019-12-26 08:41:31 +00:00
|
|
|
userSelectControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Maybe MT.UserRefine
|
|
|
|
-> UserHandler UserSelectPage
|
|
|
|
userSelectControl mcookie mrefine = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState l10n backend _ symbol version) <- ask
|
2019-10-04 07:04:23 +00:00
|
|
|
let loc = Locale
|
|
|
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
2019-09-08 15:27:38 +00:00
|
|
|
euser <- liftIO $ runClientM
|
2019-12-26 08:41:31 +00:00
|
|
|
(userList mrefine)
|
2019-09-16 07:44:46 +00:00
|
|
|
backend
|
2019-09-08 15:27:38 +00:00
|
|
|
case euser of
|
|
|
|
Right uss ->
|
2019-12-20 07:49:06 +00:00
|
|
|
return $ userSelectPage l10n loc uss version mcookie
|
2019-09-08 15:27:38 +00:00
|
|
|
Left err ->
|
|
|
|
error $ show err
|
2019-09-11 04:27:54 +00:00
|
|
|
|
2019-10-04 07:04:23 +00:00
|
|
|
userNewControl :: Maybe T.Text -> UserHandler UserNewPage
|
|
|
|
userNewControl mcookie = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState l10n _ _ symbol version) <- ask
|
2019-10-04 07:04:23 +00:00
|
|
|
let loc = Locale
|
|
|
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
2019-12-20 07:49:06 +00:00
|
|
|
return $ userNewPage l10n loc version mcookie
|
2019-09-17 19:29:56 +00:00
|
|
|
|
|
|
|
userNewPostControl
|
2019-10-04 07:04:23 +00:00
|
|
|
:: Maybe T.Text
|
|
|
|
-> MT.UserSubmit
|
2019-09-17 19:29:56 +00:00
|
|
|
-> UserHandler UserSelectPage
|
2019-10-16 16:07:12 +00:00
|
|
|
userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do
|
|
|
|
backend <- asks rsBackend
|
2019-09-17 19:29:56 +00:00
|
|
|
hashedPass <- hashPassword pass
|
|
|
|
void $ liftIO $ runClientM
|
|
|
|
(userNew $us
|
|
|
|
{ MT.userSubmitPassHash = hashedPass
|
|
|
|
})
|
|
|
|
backend
|
2019-12-26 08:41:31 +00:00
|
|
|
throwError $ redirect303 (userSelectLink Nothing)
|
2019-09-17 19:29:56 +00:00
|
|
|
|
2019-10-04 07:04:23 +00:00
|
|
|
userOverviewControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Int
|
2019-10-14 04:38:16 +00:00
|
|
|
-> Maybe MT.ProductRefine
|
2019-10-04 07:04:23 +00:00
|
|
|
-> UserHandler UserOverviewPage
|
2019-10-14 04:38:16 +00:00
|
|
|
userOverviewControl mcookie uid mRefine = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState l10n backend _ symbol version) <- ask
|
2019-10-04 07:04:23 +00:00
|
|
|
let loc = Locale
|
|
|
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
2019-10-15 05:22:04 +00:00
|
|
|
mParsedCookie = fmap parseCookieText mcookie
|
2019-10-16 16:22:51 +00:00
|
|
|
(token, mAuthUser) = parseTokenAndUser mcookie
|
2019-10-15 05:22:04 +00:00
|
|
|
mMethod = T.unpack <$>
|
|
|
|
(lookup "x-method" =<< mParsedCookie)
|
2019-10-21 18:41:58 +00:00
|
|
|
getProducts = liftIO $ runClientM
|
|
|
|
(productShortList mRefine)
|
|
|
|
backend
|
2019-10-16 16:07:12 +00:00
|
|
|
euser <- liftIO $
|
2019-10-14 04:38:16 +00:00
|
|
|
runClientM
|
2019-10-15 05:22:04 +00:00
|
|
|
(userGet (mkAuthenticatedRequest token authenticateReq))
|
2019-10-14 04:38:16 +00:00
|
|
|
backend
|
2019-12-12 02:41:22 +00:00
|
|
|
eproducts <- case fmap (toEnum . read) mMethod of
|
2019-10-21 18:41:58 +00:00
|
|
|
Just MT.PrimaryPass -> return (Right [])
|
|
|
|
Just MT.SecondaryPass -> getProducts
|
|
|
|
Just MT.ChallengeResponse -> getProducts
|
|
|
|
_ -> return (Right [])
|
2019-09-18 13:24:23 +00:00
|
|
|
case (euser, eproducts) of
|
|
|
|
(Right ud, Right prods) ->
|
2019-10-14 13:07:17 +00:00
|
|
|
case mMethod of
|
|
|
|
Just method ->
|
2020-05-10 09:31:23 +00:00
|
|
|
if mAuthUser == Just uid
|
2019-10-15 05:22:04 +00:00
|
|
|
then
|
2019-10-24 16:05:22 +00:00
|
|
|
return $
|
2019-12-20 07:49:06 +00:00
|
|
|
userOverviewPage
|
|
|
|
l10n
|
|
|
|
loc
|
|
|
|
(toEnum $ read method)
|
|
|
|
ud
|
|
|
|
prods
|
|
|
|
version
|
|
|
|
mcookie
|
|
|
|
symbol
|
2019-10-15 05:22:04 +00:00
|
|
|
else
|
|
|
|
redirectOverAuth
|
|
|
|
(Just uid)
|
|
|
|
(Just $ userOverviewLink uid mRefine)
|
|
|
|
mRefine
|
2019-10-14 13:07:17 +00:00
|
|
|
Nothing ->
|
2020-05-10 09:31:23 +00:00
|
|
|
redirectOverAuth mAuthUser Nothing mRefine
|
2019-09-18 13:24:23 +00:00
|
|
|
(Left uerr, Right _) -> case uerr of
|
|
|
|
FailureResponse _ resp ->
|
|
|
|
if statusCode (responseStatusCode resp) == 401
|
2019-10-14 13:07:17 +00:00
|
|
|
then
|
2019-10-14 19:41:28 +00:00
|
|
|
redirectOverAuth (Just uid) Nothing mRefine
|
2019-09-18 13:24:23 +00:00
|
|
|
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
|
2019-10-16 16:07:12 +00:00
|
|
|
{ errBody = fromString (show uerr) <> " " <> fromString (show perr)
|
2019-09-18 13:24:23 +00:00
|
|
|
}
|
2019-10-14 13:07:17 +00:00
|
|
|
|
2019-11-01 11:22:28 +00:00
|
|
|
userRechargeControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Int
|
|
|
|
-> UserHandler UserRechargePage
|
|
|
|
userRechargeControl mcookie uid = do
|
|
|
|
l10n <- asks rsL10n
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState l10n backend _ symbol version) <- ask
|
2019-11-01 11:22:28 +00:00
|
|
|
let loc = localeFromCookie mcookie
|
2019-12-20 07:49:06 +00:00
|
|
|
return $ userRechargePage l10n loc version mcookie uid symbol
|
2019-11-01 11:22:28 +00:00
|
|
|
|
|
|
|
userPostRechargeControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Int
|
|
|
|
-> UserRecharge
|
|
|
|
-> UserHandler UserOverviewPage
|
|
|
|
userPostRechargeControl mcookie uid (UserRecharge amount) = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState l10n backend _ _ _) <- ask
|
2019-11-01 11:22:28 +00:00
|
|
|
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 $
|
2019-12-12 02:41:22 +00:00
|
|
|
addMessage (translate l10n loc "Recharge Successful") $
|
2019-11-01 11:22:28 +00:00
|
|
|
redirect303 (userOverviewLink uid Nothing)
|
|
|
|
Left err -> throwError $
|
2019-12-12 02:41:22 +00:00
|
|
|
addMessage (translate l10n loc ("An error occured. " <>
|
2019-11-01 11:22:28 +00:00
|
|
|
fromString (show err))) $
|
|
|
|
redirect303 (userRechargeLink uid)
|
|
|
|
else
|
|
|
|
redirectOverAuth (Just uid) (Just (userRechargeLink uid)) Nothing
|
|
|
|
where
|
|
|
|
translate l10n locale = localize l10n locale . gettext
|
|
|
|
|
2019-10-14 13:07:17 +00:00
|
|
|
userManageControl
|
|
|
|
:: Maybe T.Text
|
2019-10-15 06:38:32 +00:00
|
|
|
-> Int
|
2019-10-14 13:07:17 +00:00
|
|
|
-> UserHandler UserManagePage
|
2019-10-15 06:38:32 +00:00
|
|
|
userManageControl mcookie uid = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState l10n backend _ symbol version) <- ask
|
2019-11-01 11:22:28 +00:00
|
|
|
let loc = localeFromCookie mcookie
|
2019-10-16 16:22:51 +00:00
|
|
|
(token, mAuthUser) = parseTokenAndUser mcookie
|
2019-10-16 16:07:12 +00:00
|
|
|
eUserDetails <- liftIO $
|
2019-10-14 13:07:17 +00:00
|
|
|
runClientM
|
|
|
|
(userGet (mkAuthenticatedRequest token authenticateReq))
|
|
|
|
backend
|
2019-10-16 16:07:12 +00:00
|
|
|
eAuthOverviews <- liftIO $
|
2019-10-14 13:07:17 +00:00
|
|
|
runClientM
|
|
|
|
(authManageList (mkAuthenticatedRequest token authenticateReq))
|
|
|
|
backend
|
|
|
|
case (eUserDetails, eAuthOverviews) of
|
|
|
|
(Right userDetails, Right authOverviews) ->
|
2020-05-10 09:31:23 +00:00
|
|
|
if Just uid == mAuthUser
|
2019-10-15 06:38:32 +00:00
|
|
|
then
|
2019-12-20 07:49:06 +00:00
|
|
|
return $
|
|
|
|
userManagePage l10n loc userDetails authOverviews version mcookie
|
2019-10-15 06:38:32 +00:00
|
|
|
else
|
|
|
|
redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing
|
2019-10-14 15:40:20 +00:00
|
|
|
err -> handleErrors
|
2019-10-15 06:38:32 +00:00
|
|
|
(Just uid)
|
|
|
|
(Just $ userManageLink uid)
|
2019-10-14 15:40:20 +00:00
|
|
|
[leftToMaybe (fst err), leftToMaybe (snd err)]
|
2019-10-14 13:07:17 +00:00
|
|
|
|
2019-10-16 16:07:12 +00:00
|
|
|
userManageDetailsSubmitControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Int
|
|
|
|
-> MT.UserDetailsSubmit
|
|
|
|
-> UserHandler UserOverviewPage
|
2019-10-15 06:38:32 +00:00
|
|
|
userManageDetailsSubmitControl mcookie uid uds = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState _ backend _ _ _) <- ask
|
2019-10-16 16:22:51 +00:00
|
|
|
let (token, mAuthUser) = parseTokenAndUser mcookie
|
2019-10-14 15:40:20 +00:00
|
|
|
eReturn <- liftIO $ runClientM
|
|
|
|
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
|
|
|
|
backend
|
|
|
|
case eReturn of
|
2019-10-15 06:38:32 +00:00
|
|
|
Right _ -> throwError $ redirect303 (userManageLink uid)
|
2019-10-14 19:41:28 +00:00
|
|
|
Left err ->
|
2020-05-10 09:31:23 +00:00
|
|
|
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
|
2019-10-14 13:07:17 +00:00
|
|
|
|
2019-10-16 16:07:12 +00:00
|
|
|
userManageAuthCreateControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Int
|
|
|
|
-> AuthSubmitReturn
|
|
|
|
-> UserHandler UserOverviewPage
|
2019-10-15 06:38:32 +00:00
|
|
|
userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
|
2019-12-20 07:49:06 +00:00
|
|
|
(ReadState _ backend _ _ _) <- ask
|
2019-10-16 16:22:51 +00:00
|
|
|
let (token, mAuthUser) = parseTokenAndUser mcookie
|
2019-10-14 15:40:20 +00:00
|
|
|
hashedPass <- hashPassword pass
|
|
|
|
eReturn <- liftIO $ runClientM
|
|
|
|
(authManageNewAuth
|
|
|
|
(mkAuthenticatedRequest token authenticateReq)
|
|
|
|
(MT.AuthSubmit (toEnum method) comment hashedPass)
|
|
|
|
)
|
|
|
|
backend
|
|
|
|
case eReturn of
|
2019-10-15 06:38:32 +00:00
|
|
|
Right _ -> throwError $ redirect303 $ userManageLink uid
|
2019-10-14 19:41:28 +00:00
|
|
|
Left err ->
|
2020-05-10 09:31:23 +00:00
|
|
|
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
|
2019-10-14 13:07:17 +00:00
|
|
|
|
2019-10-16 16:07:12 +00:00
|
|
|
userManageAuthDeleteControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> Int
|
|
|
|
-> AuthDetailId
|
|
|
|
-> UserHandler UserOverviewPage
|
2019-10-15 06:38:32 +00:00
|
|
|
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
|
2019-10-21 18:41:58 +00:00
|
|
|
backend <- asks rsBackend
|
2019-10-16 16:22:51 +00:00
|
|
|
let (token, mAuthUser) = parseTokenAndUser mcookie
|
2019-10-14 15:40:20 +00:00
|
|
|
eReturn <- liftIO $ runClientM
|
|
|
|
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
|
|
|
|
backend
|
|
|
|
case eReturn of
|
2019-10-15 06:38:32 +00:00
|
|
|
Right _ -> throwError $ redirect303 $ userManageLink uid
|
2019-10-14 15:40:20 +00:00
|
|
|
Left err -> case err of
|
|
|
|
FailureResponse _ resp ->
|
|
|
|
if statusCode (responseStatusCode resp) == 406
|
|
|
|
then
|
2019-10-21 18:41:58 +00:00
|
|
|
throwError (redirect303 $ userManageLink uid)
|
2019-10-14 15:40:20 +00:00
|
|
|
else
|
2020-05-10 09:31:23 +00:00
|
|
|
handleErrors mAuthUser Nothing [Just err]
|
|
|
|
_ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
|
2019-12-26 08:41:31 +00:00
|
|
|
[Just err]
|