210 lines
5.7 KiB
Haskell
210 lines
5.7 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 Servant.Server
|
|
|
|
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, when)
|
|
import Control.Monad.Reader (ask)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import Network.HTTP.Types.Status
|
|
|
|
-- imports from "mateamt"
|
|
|
|
import qualified "mateamt" API as MA
|
|
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 backend _) <- 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 ident email pass) = do
|
|
backend <- rsBackend <$> ask
|
|
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)
|
|
let mMethod = T.unpack <$>
|
|
(lookup "x-method" =<< fmap parseCookieText mcookie)
|
|
euser <- liftIO $ do
|
|
let mToken = T.unpack $ fromMaybe "secret" $
|
|
lookup "x-token" =<< fmap parseCookieText mcookie
|
|
runClientM
|
|
(userGet (mkAuthenticatedRequest mToken authenticateReq))
|
|
backend
|
|
eproducts <- liftIO $ runClientM
|
|
(productShortList mRefine)
|
|
backend
|
|
case (euser, eproducts) of
|
|
(Right ud, Right prods) ->
|
|
case mMethod of
|
|
Just method ->
|
|
return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
|
|
Nothing ->
|
|
redirectOverAuth (Just uid) mRefine
|
|
(Left uerr, Right _) -> case uerr of
|
|
FailureResponse _ resp ->
|
|
if statusCode (responseStatusCode resp) == 401
|
|
then
|
|
redirectOverAuth (Just uid) 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)
|
|
}
|
|
|
|
redirectOverAuth
|
|
:: Maybe Int
|
|
-> Maybe (MT.ProductRefine)
|
|
-> UserHandler UserOverviewPage
|
|
redirectOverAuth muid mRefine = do
|
|
let redirectHeaders = errHeaders $
|
|
redirect303 (authLink (Just $ "/" <>
|
|
fromString (show $ linkURI (case muid of
|
|
Just uid -> userOverviewLink uid mRefine
|
|
Nothing -> userSelectLink
|
|
))))
|
|
throwError
|
|
(err303
|
|
{ errHeaders = redirectHeaders ++ (case muid of
|
|
Just uid ->
|
|
[ ( "Set-Cookie"
|
|
, "x-auth-user=" <> (fromString $ show uid) <> "; Path=/"
|
|
)
|
|
]
|
|
Nothing ->
|
|
[
|
|
]
|
|
)
|
|
++
|
|
[ ( "Set-Cookie"
|
|
, "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
|
|
)
|
|
, ( "Set-Cookie"
|
|
, "x-method=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
|
|
)
|
|
]
|
|
}
|
|
)
|
|
|
|
userManageControl
|
|
:: Maybe T.Text
|
|
-> UserHandler UserManagePage
|
|
userManageControl mcookie = do
|
|
(ReadState l10n backend _) <- ask
|
|
let loc = Locale
|
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
|
token = T.unpack $ fromMaybe "secret" $
|
|
(lookup "x-token" =<< fmap parseCookieText mcookie)
|
|
eUserDetails <- liftIO $ do
|
|
runClientM
|
|
(userGet (mkAuthenticatedRequest token authenticateReq))
|
|
backend
|
|
eAuthOverviews <- liftIO $ do
|
|
runClientM
|
|
(authManageList (mkAuthenticatedRequest token authenticateReq))
|
|
backend
|
|
case (eUserDetails, eAuthOverviews) of
|
|
(Right userDetails, Right authOverviews) ->
|
|
return $ userManagePage l10n loc userDetails authOverviews
|
|
err -> handleErrors [leftToMaybe (fst err), leftToMaybe (snd err)]
|
|
where
|
|
handleErrors merrs = do
|
|
codes <- mapM
|
|
(\eerr -> case eerr of
|
|
Just (FailureResponse _ resp) ->
|
|
return $ statusCode (responseStatusCode resp)
|
|
Just err ->
|
|
throwError $ err500
|
|
{ errBody = fromString (show err)
|
|
}
|
|
Nothing ->
|
|
return 200
|
|
)
|
|
merrs
|
|
if (any (== 401) codes)
|
|
then
|
|
redirectOverAuth Nothing Nothing
|
|
else
|
|
throwError $ err500
|
|
{ errBody = "Could not handle errors in handleErrors"
|
|
}
|
|
|
|
userManageDetailsSubmitControl mcookie _ =
|
|
error "not yet implemented"
|
|
|
|
userManageAuthCreateControl mcookie _ =
|
|
error "not yet implemented"
|
|
|
|
userManageAuthDeleteControl mcookie _ =
|
|
error "not yet implemented"
|