matebeamter/src/Control/User.hs

274 lines
8 KiB
Haskell
Raw Normal View History

2019-09-08 10:48:57 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
2019-10-04 07:04:23 +00:00
{-# LANGUAGE DataKinds #-}
{-# 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)
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
userSelectControl
:: Maybe T.Text
-> Maybe MT.UserRefine
-> UserHandler UserSelectPage
userSelectControl mcookie mrefine = do
(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
(userList mrefine)
2019-09-16 07:44:46 +00:00
backend
2019-09-08 15:27:38 +00:00
case euser of
Right uss ->
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
(ReadState l10n _ _ symbol version) <- ask
2019-10-04 07:04:23 +00:00
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
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
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
-> Maybe MT.ProductRefine
2019-10-04 07:04:23 +00:00
-> UserHandler UserOverviewPage
userOverviewControl mcookie uid mRefine = do
(ReadState l10n backend _ symbol version) <- ask
2019-10-04 07:04:23 +00:00
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
2019-10-16 16:22:51 +00:00
(token, mAuthUser) = parseTokenAndUser mcookie
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 $
runClientM
(userGet (mkAuthenticatedRequest token authenticateReq))
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) ->
case mMethod of
Just method ->
if mAuthUser == Just uid
then
2019-10-24 16:05:22 +00:00
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
2019-09-18 13:24:23 +00:00
(Left uerr, Right _) -> case uerr of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
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-11-01 11:22:28 +00:00
userRechargeControl
:: Maybe T.Text
-> Int
-> UserHandler UserRechargePage
userRechargeControl mcookie uid = do
l10n <- asks rsL10n
(ReadState l10n backend _ symbol version) <- ask
2019-11-01 11:22:28 +00:00
let loc = localeFromCookie mcookie
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
(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
userManageControl
:: Maybe T.Text
2019-10-15 06:38:32 +00:00
-> Int
-> UserHandler UserManagePage
2019-10-15 06:38:32 +00:00
userManageControl mcookie uid = do
(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 $
runClientM
(userGet (mkAuthenticatedRequest token authenticateReq))
backend
2019-10-16 16:07:12 +00:00
eAuthOverviews <- liftIO $
runClientM
(authManageList (mkAuthenticatedRequest token authenticateReq))
backend
case (eUserDetails, eAuthOverviews) of
(Right userDetails, Right authOverviews) ->
if Just uid == mAuthUser
2019-10-15 06:38:32 +00:00
then
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-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
(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 ->
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
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
(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 ->
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
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
handleErrors mAuthUser Nothing [Just err]
_ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
[Just err]