2019-09-08 10:48:57 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
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 Servant.Server
|
|
|
|
|
|
|
|
import Data.String (fromString)
|
2019-09-08 10:48:57 +00:00
|
|
|
|
2019-09-08 15:27:38 +00:00
|
|
|
import Data.Text.I18n
|
|
|
|
|
2019-09-17 19:29:56 +00:00
|
|
|
import Control.Monad (void)
|
2019-09-08 10:48:57 +00:00
|
|
|
import Control.Monad.Reader (ask)
|
|
|
|
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" API as MA
|
|
|
|
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-09-11 04:27:54 +00:00
|
|
|
userSelectControl :: UserHandler UserSelectPage
|
|
|
|
userSelectControl = do
|
2019-09-17 19:29:56 +00:00
|
|
|
(ReadState l10n backend _) <- ask
|
2019-09-08 15:27:38 +00:00
|
|
|
let loc = Locale "en"
|
|
|
|
euser <- liftIO $ runClientM
|
2019-09-16 07:44:46 +00:00
|
|
|
(userList (Nothing))
|
|
|
|
backend
|
2019-09-08 15:27:38 +00:00
|
|
|
case euser of
|
|
|
|
Right uss ->
|
2019-09-11 04:27:54 +00:00
|
|
|
return $ userSelectPage l10n loc uss
|
2019-09-08 15:27:38 +00:00
|
|
|
Left err ->
|
|
|
|
error $ show err
|
2019-09-11 04:27:54 +00:00
|
|
|
|
2019-09-17 19:29:56 +00:00
|
|
|
userNewControl :: UserHandler UserNewPage
|
|
|
|
userNewControl = do
|
|
|
|
(ReadState l10n backend _) <- ask
|
|
|
|
let loc = Locale "en"
|
|
|
|
return $ userNewPage l10n loc
|
|
|
|
|
|
|
|
userNewPostControl
|
|
|
|
:: 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
|
2019-09-18 13:24:23 +00:00
|
|
|
redirect303 userSelectLink
|
2019-09-17 19:29:56 +00:00
|
|
|
|
2019-09-11 04:27:54 +00:00
|
|
|
userOverviewControl :: Int -> UserHandler UserOverviewPage
|
|
|
|
userOverviewControl uid = do
|
2019-09-18 13:24:23 +00:00
|
|
|
(ReadState l10n backend _) <- ask
|
|
|
|
let loc = Locale "en"
|
|
|
|
euser <- liftIO $ runClientM
|
|
|
|
(userGet (mkAuthenticatedRequest "secret" authenticateReq) uid)
|
|
|
|
backend
|
|
|
|
eproducts <- liftIO $ runClientM
|
|
|
|
(productShortList Nothing)
|
|
|
|
backend
|
|
|
|
case (euser, eproducts) of
|
|
|
|
(Right ud, Right prods) ->
|
|
|
|
return $ userOverviewPage l10n loc ud prods
|
|
|
|
(Left uerr, Right _) -> case uerr of
|
|
|
|
FailureResponse _ resp ->
|
|
|
|
if statusCode (responseStatusCode resp) == 401
|
|
|
|
then
|
|
|
|
redirect303 authLink
|
|
|
|
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)
|
|
|
|
}
|