matebeamter/src/Control/User.hs

210 lines
5.7 KiB
Haskell
Raw Normal View History

2019-09-08 10:48:57 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
2019-10-04 07:04:23 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
2019-09-08 10:48:57 +00:00
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-10-04 07:04:23 +00:00
import qualified Data.Text as T
2019-09-08 15:27:38 +00:00
import Data.Text.I18n
2019-10-04 07:04:23 +00:00
import Data.Maybe (fromMaybe)
import Data.Either.Combinators (leftToMaybe)
2019-10-04 07:04:23 +00:00
import Control.Monad (void, when)
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-10-04 07:04:23 +00:00
userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage
userSelectControl mcookie = do
2019-09-17 19:29:56 +00:00
(ReadState l10n backend _) <- ask
2019-10-04 07:04:23 +00:00
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
2019-09-08 15:27:38 +00:00
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-10-04 07:04:23 +00:00
userNewControl :: Maybe T.Text -> UserHandler UserNewPage
userNewControl mcookie = do
2019-09-17 19:29:56 +00:00
(ReadState l10n backend _) <- ask
2019-10-04 07:04:23 +00:00
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
2019-09-17 19:29:56 +00:00
return $ userNewPage l10n loc
userNewPostControl
2019-10-04 07:04:23 +00:00
:: Maybe T.Text
-> MT.UserSubmit
2019-09-17 19:29:56 +00:00
-> UserHandler UserSelectPage
2019-10-04 07:04:23 +00:00
userNewPostControl _ us@(MT.UserSubmit ident email pass) = do
2019-09-17 19:29:56 +00:00
backend <- rsBackend <$> ask
hashedPass <- hashPassword pass
void $ liftIO $ runClientM
(userNew $us
{ MT.userSubmitPassHash = hashedPass
})
backend
2019-10-04 07:04:23 +00:00
throwError $ redirect303 userSelectLink
2019-09-17 19:29:56 +00:00
2019-10-04 07:04:23 +00:00
userOverviewControl
:: Maybe T.Text
-> Int
-> Maybe MT.ProductRefine
2019-10-04 07:04:23 +00:00
-> UserHandler UserOverviewPage
userOverviewControl mcookie uid mRefine = do
2019-09-18 13:24:23 +00:00
(ReadState l10n backend _) <- ask
2019-10-04 07:04:23 +00:00
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
2019-09-18 13:24:23 +00:00
eproducts <- liftIO $ runClientM
(productShortList mRefine)
2019-09-18 13:24:23 +00:00
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
2019-09-18 13:24:23 +00:00
(Left uerr, Right _) -> case uerr of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then
redirectOverAuth (Just uid) mRefine
2019-09-18 13:24:23 +00:00
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"