{-# 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) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ lookup "x-token" =<< mParsedCookie mAuthUser = T.unpack <$> (lookup "x-auth-user" =<< mParsedCookie) mMethod = T.unpack <$> (lookup "x-method" =<< mParsedCookie) euser <- liftIO $ do runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend eproducts <- liftIO $ runClientM (productShortList mRefine) backend case (euser, eproducts) of (Right ud, Right prods) -> case mMethod of Just method -> if fmap read mAuthUser == Just uid then return $ userOverviewPage l10n loc (toEnum $ read method) ud prods else redirectOverAuth (Just uid) (Just $ userOverviewLink uid mRefine) mRefine Nothing -> redirectOverAuth (read <$> mAuthUser) Nothing mRefine (Left uerr, Right _) -> case uerr of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 401 then redirectOverAuth (Just uid) Nothing 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) } userManageControl :: Maybe T.Text -> UserHandler UserManagePage userManageControl mcookie = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ ((lookup "x-token") =<< mParsedCookie) mAuthUser = T.unpack <$> ((lookup "x-auth-user") =<< mParsedCookie) 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 (fmap read mAuthUser) (Just userManageLink) [leftToMaybe (fst err), leftToMaybe (snd err)] userManageDetailsSubmitControl mcookie uds = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ ((lookup "x-token") =<< mParsedCookie) mAuthUser = T.unpack <$> ((lookup "x-auth-user") =<< mParsedCookie) eReturn <- liftIO $ runClientM (userUpdate (mkAuthenticatedRequest token authenticateReq) uds) backend case eReturn of Right _ -> throwError $ redirect303 userManageLink Left err -> handleErrors (fmap read mAuthUser) (Just userManageLink) [Just err] userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ ((lookup "x-token") =<< mParsedCookie) mAuthUser = T.unpack <$> ((lookup "x-auth-user") =<< mParsedCookie) hashedPass <- hashPassword pass eReturn <- liftIO $ runClientM (authManageNewAuth (mkAuthenticatedRequest token authenticateReq) (MT.AuthSubmit (toEnum method) comment hashedPass) ) backend case eReturn of Right _ -> throwError $ redirect303 userManageLink Left err -> handleErrors (fmap read mAuthUser) (Just userManageLink) [Just err] userManageAuthDeleteControl mcookie (AuthDetailId adid) = do (ReadState l10n backend _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" $ ((lookup "x-token") =<< mParsedCookie) mAuthUser = T.unpack <$> ((lookup "x-auth-user") =<< mParsedCookie) eReturn <- liftIO $ runClientM (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) backend case eReturn of Right _ -> throwError $ redirect303 userManageLink Left err -> case err of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 406 then throwError $ redirect303 userManageLink else handleErrors (fmap read mAuthUser) Nothing [Just err] _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]