matebeamter/src/Control/User.hs

101 lines
2.4 KiB
Haskell
Raw Normal View History

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)
}