matebeamter/src/Control/User.hs
2019-09-18 15:24:23 +02:00

101 lines
2.4 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Control.User where
import Servant
import Servant.Client
import Servant.Client.Core.Auth
import Servant.Server
import Data.String (fromString)
import Data.Text.I18n
import Control.Monad (void)
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 :: UserHandler UserSelectPage
userSelectControl = do
(ReadState l10n backend _) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userList (Nothing))
backend
case euser of
Right uss ->
return $ userSelectPage l10n loc uss
Left err ->
error $ show err
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
redirect303 userSelectLink
userOverviewControl :: Int -> UserHandler UserOverviewPage
userOverviewControl uid = do
(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)
}