matebeamter/src/Control/User.hs

235 lines
7.1 KiB
Haskell

{-# 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)
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 -> UserHandler UserSelectPage
userSelectControl mcookie = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
euser <- liftIO $ runClientM
(userList Nothing)
backend
case euser of
Right uss ->
return $ userSelectPage l10n loc uss
Left err ->
error $ show err
userNewControl :: Maybe T.Text -> UserHandler UserNewPage
userNewControl mcookie = do
(ReadState l10n _ _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
return $ userNewPage l10n loc
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
userOverviewControl
:: Maybe T.Text
-> Int
-> Maybe MT.ProductRefine
-> UserHandler UserOverviewPage
userOverviewControl mcookie uid mRefine = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $
lookup "x-token" =<< mParsedCookie
mAuthUser = T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie)
mMethod = T.unpack <$>
(lookup "x-method" =<< mParsedCookie)
euser <- liftIO $
runClientM
(userGet (mkAuthenticatedRequest token authenticateReq))
backend
eproducts <- liftIO $ runClientM
(productShortList mRefine)
backend
case (euser, eproducts) of
(Right ud, Right prods) ->
case mMethod of
Just method ->
if fmap read mAuthUser == Just uid
then
return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
else
redirectOverAuth
(Just uid)
(Just $ userOverviewLink uid mRefine)
mRefine
Nothing ->
redirectOverAuth (read <$> 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)
}
userManageControl
:: Maybe T.Text
-> Int
-> UserHandler UserManagePage
userManageControl mcookie uid = do
(ReadState l10n backend _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie)
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 == fmap read mAuthUser
then
return $ userManagePage l10n loc userDetails authOverviews
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 mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie)
eReturn <- liftIO $ runClientM
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
backend
case eReturn of
Right _ -> throwError $ redirect303 (userManageLink uid)
Left err ->
handleErrors (fmap read 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 mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie)
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 (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
userManageAuthDeleteControl
:: Maybe T.Text
-> Int
-> AuthDetailId
-> UserHandler UserOverviewPage
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
(ReadState _ backend _) <- ask
let mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie)
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 (fmap read mAuthUser) Nothing [Just err]
_ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]